source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 c      print *,"Processor",myrank," computed USCSC"
 125 #ifdef TIMING
 126       time01=MPI_Wtime()
 127 #endif
 128       call vec_and_deriv
 129 #ifdef TIMING
 130       time_vec=time_vec+MPI_Wtime()-time01
 131 #endif
 132 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 133       if (ipot.lt.6) then
 134 #ifdef SPLITELE
 135          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 136      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 137      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 138      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 139 #else
 140          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #endif
 145             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 146          else
 147             ees=0.0d0
 148             evdw1=0.0d0
 149             eel_loc=0.0d0
 150             eello_turn3=0.0d0
 151             eello_turn4=0.0d0
 152          endif
 153       else
 154 c        write (iout,*) "Soft-spheer ELEC potential"
 155         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 156      &   eello_turn4)
 157       endif
 158 c      print *,"Processor",myrank," computed UELEC"
 159 C
 160 C Calculate excluded-volume interaction energy between peptide groups
 161 C and side chains.
 162 C
 163       if (ipot.lt.6) then
 164        if(wscp.gt.0d0) then
 165         call escp(evdw2,evdw2_14)
 166        else
 167         evdw2=0
 168         evdw2_14=0
 169        endif
 170       else
 171 c        write (iout,*) "Soft-sphere SCP potential"
 172         call escp_soft_sphere(evdw2,evdw2_14)
 173       endif
 174 c
 175 c Calculate the bond-stretching energy
 176 c
 177       call ebond(estr)
 178 C
 179 C Calculate the disulfide-bridge and other energy and the contributions
 180 C from other distance constraints.
 181 cd    print *,'Calling EHPB'
 182       call edis(ehpb)
 183 cd    print *,'EHPB exitted succesfully.'
 184 C
 185 C Calculate the virtual-bond-angle energy.
 186 C
 187       if (wang.gt.0d0) then
 188         call ebend(ebe)
 189       else
 190         ebe=0
 191       endif
 192 c      print *,"Processor",myrank," computed UB"
 193 C
 194 C Calculate the SC local energy.
 195 C
 196       call esc(escloc)
 197 c      print *,"Processor",myrank," computed USC"
 198 C
 199 C Calculate the virtual-bond torsional energy.
 200 C
 201 cd    print *,'nterm=',nterm
 202       if (wtor.gt.0) then
 203        call etor(etors,edihcnstr)
 204       else
 205        etors=0
 206        edihcnstr=0
 207       endif
 208 c      print *,"Processor",myrank," computed Utor"
 209 C
 210 C 6/23/01 Calculate double-torsional energy
 211 C
 212       if (wtor_d.gt.0) then
 213        call etor_d(etors_d)
 214       else
 215        etors_d=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utord"
 218 C
 219 C 21/5/07 Calculate local sicdechain correlation energy
 220 C
 221       if (wsccor.gt.0.0d0) then
 222         call eback_sc_corr(esccor)
 223       else
 224         esccor=0.0d0
 225       endif
 226 c      print *,"Processor",myrank," computed Usccorr"
 227 C
 228 C 12/1/95 Multi-body terms
 229 C
 230       n_corr=0
 231       n_corr1=0
 232       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 233      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 234          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 235 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 236 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 237       else
 238          ecorr=0.0d0
 239          ecorr5=0.0d0
 240          ecorr6=0.0d0
 241          eturn6=0.0d0
 242       endif
 243       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 244          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 245 cd         write (iout,*) "multibody_hb ecorr",ecorr
 246       endif
 247 c      print *,"Processor",myrank," computed Ucorr"
 248 C
 249 C If performing constraint dynamics, call the constraint energy
 250 C  after the equilibration time
 251       if(usampl.and.totT.gt.eq_time) then
 252          call EconstrQ
 253          call Econstr_back
 254       else
 255          Uconst=0.0d0
 256          Uconst_back=0.0d0
 257       endif
 258 #ifdef TIMING
 259       time_enecalc=time_enecalc+MPI_Wtime()-time00
 260 #endif
 261 c      print *,"Processor",myrank," computed Uconstr"
 262 #ifdef TIMING
 263       time00=MPI_Wtime()
 264 #endif
 265 c
 266 C Sum the energies
 267 C
 268       energia(1)=evdw
 269 #ifdef SCP14
 270       energia(2)=evdw2-evdw2_14
 271       energia(18)=evdw2_14
 272 #else
 273       energia(2)=evdw2
 274       energia(18)=0.0d0
 275 #endif
 276 #ifdef SPLITELE
 277       energia(3)=ees
 278       energia(16)=evdw1
 279 #else
 280       energia(3)=ees+evdw1
 281       energia(16)=0.0d0
 282 #endif
 283       energia(4)=ecorr
 284       energia(5)=ecorr5
 285       energia(6)=ecorr6
 286       energia(7)=eel_loc
 287       energia(8)=eello_turn3
 288       energia(9)=eello_turn4
 289       energia(10)=eturn6
 290       energia(11)=ebe
 291       energia(12)=escloc
 292       energia(13)=etors
 293       energia(14)=etors_d
 294       energia(15)=ehpb
 295       energia(19)=edihcnstr
 296       energia(17)=estr
 297       energia(20)=Uconst+Uconst_back
 298       energia(21)=esccor
 299 c    Here are the energies showed per procesor if the are more processors
 300 c    per molecule then we sum it up in sum_energy subroutine
 301 c      print *," Processor",myrank," calls SUM_ENERGY"
 302       call sum_energy(energia,.true.)
 303 c      print *," Processor",myrank," left SUM_ENERGY"
 304 #ifdef TIMING
 305       time_sumene=time_sumene+MPI_Wtime()-time00
 306 #endif
 307       return
 308       end
 309 c-------------------------------------------------------------------------------
 310       subroutine sum_energy(energia,reduce)
 311       implicit real*8 (a-h,o-z)
 312       include 'DIMENSIONS'
 313 #ifndef ISNAN
 314       external proc_proc
 315 #ifdef WINPGI
 316 cMS$ATTRIBUTES C ::  proc_proc
 317 #endif
 318 #endif
 319 #ifdef MPI
 320       include "mpif.h"
 321 #endif
 322       include 'COMMON.SETUP'
 323       include 'COMMON.IOUNITS'
 324       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 325       include 'COMMON.FFIELD'
 326       include 'COMMON.DERIV'
 327       include 'COMMON.INTERACT'
 328       include 'COMMON.SBRIDGE'
 329       include 'COMMON.CHAIN'
 330       include 'COMMON.VAR'
 331       include 'COMMON.CONTROL'
 332       include 'COMMON.TIME1'
 333       logical reduce
 334 #ifdef MPI
 335       if (nfgtasks.gt.1 .and. reduce) then
 336 #ifdef DEBUG
 337         write (iout,*) "energies before REDUCE"
 338         call enerprint(energia)
 339         call flush(iout)
 340 #endif
 341         do i=0,n_ene
 342           enebuff(i)=energia(i)
 343         enddo
 344         time00=MPI_Wtime()
 345         call MPI_Barrier(FG_COMM,IERR)
 346         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 347         time00=MPI_Wtime()
 348         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 349      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 350 #ifdef DEBUG
 351         write (iout,*) "energies after REDUCE"
 352         call enerprint(energia)
 353         call flush(iout)
 354 #endif
 355         time_Reduce=time_Reduce+MPI_Wtime()-time00
 356       endif
 357       if (fg_rank.eq.0) then
 358 #endif
 359       evdw=energia(1)
 360 #ifdef SCP14
 361       evdw2=energia(2)+energia(18)
 362       evdw2_14=energia(18)
 363 #else
 364       evdw2=energia(2)
 365 #endif
 366 #ifdef SPLITELE
 367       ees=energia(3)
 368       evdw1=energia(16)
 369 #else
 370       ees=energia(3)
 371       evdw1=0.0d0
 372 #endif
 373       ecorr=energia(4)
 374       ecorr5=energia(5)
 375       ecorr6=energia(6)
 376       eel_loc=energia(7)
 377       eello_turn3=energia(8)
 378       eello_turn4=energia(9)
 379       eturn6=energia(10)
 380       ebe=energia(11)
 381       escloc=energia(12)
 382       etors=energia(13)
 383       etors_d=energia(14)
 384       ehpb=energia(15)
 385       edihcnstr=energia(19)
 386       estr=energia(17)
 387       Uconst=energia(20)
 388       esccor=energia(21)
 389 #ifdef SPLITELE
 390       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 391      & +wang*ebe+wtor*etors+wscloc*escloc
 392      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 393      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 394      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 395      & +wbond*estr+Uconst+wsccor*esccor
 396 #else
 397       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 398      & +wang*ebe+wtor*etors+wscloc*escloc
 399      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 400      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 401      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 402      & +wbond*estr+Uconst+wsccor*esccor
 403 #endif
 404       energia(0)=etot
 405 c detecting NaNQ
 406 #ifdef ISNAN
 407 #ifdef AIX
 408       if (isnan(etot).ne.0) energia(0)=1.0d+99
 409 #else
 410       if (isnan(etot)) energia(0)=1.0d+99
 411 #endif
 412 #else
 413       i=0
 414 #ifdef WINPGI
 415       idumm=proc_proc(etot,i)
 416 #else
 417       call proc_proc(etot,i)
 418 #endif
 419       if(i.eq.1)energia(0)=1.0d+99
 420 #endif
 421 #ifdef MPI
 422       endif
 423 #endif
 424       return
 425       end
 426 c-------------------------------------------------------------------------------
 427       subroutine sum_gradient
 428       implicit real*8 (a-h,o-z)
 429       include 'DIMENSIONS'
 430 #ifndef ISNAN
 431       external proc_proc
 432 #ifdef WINPGI
 433 cMS$ATTRIBUTES C ::  proc_proc
 434 #endif
 435 #endif
 436 #ifdef MPI
 437       include 'mpif.h'
 438       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 439      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 440 #endif
 441       include 'COMMON.SETUP'
 442       include 'COMMON.IOUNITS'
 443       include 'COMMON.FFIELD'
 444       include 'COMMON.DERIV'
 445       include 'COMMON.INTERACT'
 446       include 'COMMON.SBRIDGE'
 447       include 'COMMON.CHAIN'
 448       include 'COMMON.VAR'
 449       include 'COMMON.CONTROL'
 450       include 'COMMON.TIME1'
 451       include 'COMMON.MAXGRAD'
 452       include 'COMMON.SCCOR'
 453 #ifdef TIMING
 454       time01=MPI_Wtime()
 455 #endif
 456 #ifdef DEBUG
 457       write (iout,*) "sum_gradient gvdwc, gvdwx"
 458       do i=1,nres
 459         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 460      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 461       enddo
 462       call flush(iout)
 463 #endif
 464 #ifdef MPI
 465 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 466         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 467      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 468 #endif
 469 C
 470 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 471 C            in virtual-bond-vector coordinates
 472 C
 473 #ifdef DEBUG
 474 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 475 c      do i=1,nres-1
 476 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 477 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 478 c      enddo
 479 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 480 c      do i=1,nres-1
 481 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 482 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 483 c      enddo
 484       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 485       do i=1,nres
 486         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 487      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 488      &   g_corr5_loc(i)
 489       enddo
 490       call flush(iout)
 491 #endif
 492 #ifdef SPLITELE
 493       do i=1,nct
 494         do j=1,3
 495           gradbufc(j,i)=wsc*gvdwc(j,i)+
 496      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 497      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 498      &                wel_loc*gel_loc_long(j,i)+
 499      &                wcorr*gradcorr_long(j,i)+
 500      &                wcorr5*gradcorr5_long(j,i)+
 501      &                wcorr6*gradcorr6_long(j,i)+
 502      &                wturn6*gcorr6_turn_long(j,i)+
 503      &                wstrain*ghpbc(j,i)
 504         enddo
 505       enddo
 506 #else
 507       do i=1,nct
 508         do j=1,3
 509           gradbufc(j,i)=wsc*gvdwc(j,i)+
 510      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 511      &                welec*gelc_long(j,i)+
 512      &                wbond*gradb(j,i)+
 513      &                wel_loc*gel_loc_long(j,i)+
 514      &                wcorr*gradcorr_long(j,i)+
 515      &                wcorr5*gradcorr5_long(j,i)+
 516      &                wcorr6*gradcorr6_long(j,i)+
 517      &                wturn6*gcorr6_turn_long(j,i)+
 518      &                wstrain*ghpbc(j,i)
 519         enddo
 520       enddo
 521 #endif
 522 #ifdef MPI
 523       if (nfgtasks.gt.1) then
 524       time00=MPI_Wtime()
 525 #ifdef DEBUG
 526       write (iout,*) "gradbufc before allreduce"
 527       do i=1,nres
 528         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 529       enddo
 530       call flush(iout)
 531 #endif
 532       do i=1,nres
 533         do j=1,3
 534           gradbufc_sum(j,i)=gradbufc(j,i)
 535         enddo
 536       enddo
 537 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 538 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 539 c      time_reduce=time_reduce+MPI_Wtime()-time00
 540 #ifdef DEBUG
 541 c      write (iout,*) "gradbufc_sum after allreduce"
 542 c      do i=1,nres
 543 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 544 c      enddo
 545 c      call flush(iout)
 546 #endif
 547 #ifdef TIMING
 548 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 549 #endif
 550       do i=nnt,nres
 551         do k=1,3
 552           gradbufc(k,i)=0.0d0
 553         enddo
 554       enddo
 555 #ifdef DEBUG
 556       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 557       write (iout,*) (i," jgrad_start",jgrad_start(i),
 558      &                  " jgrad_end  ",jgrad_end(i),
 559      &                  i=igrad_start,igrad_end)
 560 #endif
 561 c
 562 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 563 c do not parallelize this part.
 564 c
 565 c      do i=igrad_start,igrad_end
 566 c        do j=jgrad_start(i),jgrad_end(i)
 567 c          do k=1,3
 568 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 569 c          enddo
 570 c        enddo
 571 c      enddo
 572       do j=1,3
 573         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 574       enddo
 575       do i=nres-2,nnt,-1
 576         do j=1,3
 577           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 578         enddo
 579       enddo
 580 #ifdef DEBUG
 581       write (iout,*) "gradbufc after summing"
 582       do i=1,nres
 583         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 584       enddo
 585       call flush(iout)
 586 #endif
 587       else
 588 #endif
 589 #ifdef DEBUG
 590       write (iout,*) "gradbufc"
 591       do i=1,nres
 592         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 593       enddo
 594       call flush(iout)
 595 #endif
 596       do i=1,nres
 597         do j=1,3
 598           gradbufc_sum(j,i)=gradbufc(j,i)
 599           gradbufc(j,i)=0.0d0
 600         enddo
 601       enddo
 602       do j=1,3
 603         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 604       enddo
 605       do i=nres-2,nnt,-1
 606         do j=1,3
 607           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 608         enddo
 609       enddo
 610 c      do i=nnt,nres-1
 611 c        do k=1,3
 612 c          gradbufc(k,i)=0.0d0
 613 c        enddo
 614 c        do j=i+1,nres
 615 c          do k=1,3
 616 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 617 c          enddo
 618 c        enddo
 619 c      enddo
 620 #ifdef DEBUG
 621       write (iout,*) "gradbufc after summing"
 622       do i=1,nres
 623         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 624       enddo
 625       call flush(iout)
 626 #endif
 627 #ifdef MPI
 628       endif
 629 #endif
 630       do k=1,3
 631         gradbufc(k,nres)=0.0d0
 632       enddo
 633       do i=1,nct
 634         do j=1,3
 635 #ifdef SPLITELE
 636           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 637      &                wel_loc*gel_loc(j,i)+
 638      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 639      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 640      &                wel_loc*gel_loc_long(j,i)+
 641      &                wcorr*gradcorr_long(j,i)+
 642      &                wcorr5*gradcorr5_long(j,i)+
 643      &                wcorr6*gradcorr6_long(j,i)+
 644      &                wturn6*gcorr6_turn_long(j,i))+
 645      &                wbond*gradb(j,i)+
 646      &                wcorr*gradcorr(j,i)+
 647      &                wturn3*gcorr3_turn(j,i)+
 648      &                wturn4*gcorr4_turn(j,i)+
 649      &                wcorr5*gradcorr5(j,i)+
 650      &                wcorr6*gradcorr6(j,i)+
 651      &                wturn6*gcorr6_turn(j,i)+
 652      &                wsccor*gsccorc(j,i)
 653      &               +wscloc*gscloc(j,i)
 654 #else
 655           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 656      &                wel_loc*gel_loc(j,i)+
 657      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 658      &                welec*gelc_long(j,i)
 659      &                wel_loc*gel_loc_long(j,i)+
 660      &                wcorr*gcorr_long(j,i)+
 661      &                wcorr5*gradcorr5_long(j,i)+
 662      &                wcorr6*gradcorr6_long(j,i)+
 663      &                wturn6*gcorr6_turn_long(j,i))+
 664      &                wbond*gradb(j,i)+
 665      &                wcorr*gradcorr(j,i)+
 666      &                wturn3*gcorr3_turn(j,i)+
 667      &                wturn4*gcorr4_turn(j,i)+
 668      &                wcorr5*gradcorr5(j,i)+
 669      &                wcorr6*gradcorr6(j,i)+
 670      &                wturn6*gcorr6_turn(j,i)+
 671      &                wsccor*gsccorc(j,i)
 672      &               +wscloc*gscloc(j,i)
 673 #endif
 674           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 675      &                  wbond*gradbx(j,i)+
 676      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 677      &                  wsccor*gsccorx(j,i)
 678      &                 +wscloc*gsclocx(j,i)
 679         enddo
 680       enddo
 681 #ifdef DEBUG
 682       write (iout,*) "gloc before adding corr"
 683       do i=1,4*nres
 684         write (iout,*) i,gloc(i,icg)
 685       enddo
 686 #endif
 687       do i=1,nres-3
 688         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 689      &   +wcorr5*g_corr5_loc(i)
 690      &   +wcorr6*g_corr6_loc(i)
 691      &   +wturn4*gel_loc_turn4(i)
 692      &   +wturn3*gel_loc_turn3(i)
 693      &   +wturn6*gel_loc_turn6(i)
 694      &   +wel_loc*gel_loc_loc(i)
 695       enddo
 696 #ifdef DEBUG
 697       write (iout,*) "gloc after adding corr"
 698       do i=1,4*nres
 699         write (iout,*) i,gloc(i,icg)
 700       enddo
 701 #endif
 702 #ifdef MPI
 703       if (nfgtasks.gt.1) then
 704         do j=1,3
 705           do i=1,nres
 706             gradbufc(j,i)=gradc(j,i,icg)
 707             gradbufx(j,i)=gradx(j,i,icg)
 708           enddo
 709         enddo
 710         do i=1,4*nres
 711           glocbuf(i)=gloc(i,icg)
 712         enddo
 713 #define DEBUG
 714 #ifdef DEBUG
 715       write (iout,*) "gloc_sc before reduce"
 716       do i=1,nres
 717        do j=1,1
 718         write (iout,*) i,j,gloc_sc(j,i,icg)
 719        enddo
 720       enddo
 721 #endif
 722 #undef DEBUG
 723         do i=1,nres
 724          do j=1,3
 725           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 726          enddo
 727         enddo
 728         time00=MPI_Wtime()
 729         call MPI_Barrier(FG_COMM,IERR)
 730         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 731         time00=MPI_Wtime()
 732         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 733      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 734         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 735      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 736         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 737      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 738         time_reduce=time_reduce+MPI_Wtime()-time00
 739         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         time_reduce=time_reduce+MPI_Wtime()-time00
 742 #define DEBUG
 743 #ifdef DEBUG
 744       write (iout,*) "gloc_sc after reduce"
 745       do i=1,nres
 746        do j=1,1
 747         write (iout,*) i,j,gloc_sc(j,i,icg)
 748        enddo
 749       enddo
 750 #endif
 751 #undef DEBUG
 752 #ifdef DEBUG
 753       write (iout,*) "gloc after reduce"
 754       do i=1,4*nres
 755         write (iout,*) i,gloc(i,icg)
 756       enddo
 757 #endif
 758       endif
 759 #endif
 760       if (gnorm_check) then
 761 c
 762 c Compute the maximum elements of the gradient
 763 c
 764       gvdwc_max=0.0d0
 765       gvdwc_scp_max=0.0d0
 766       gelc_max=0.0d0
 767       gvdwpp_max=0.0d0
 768       gradb_max=0.0d0
 769       ghpbc_max=0.0d0
 770       gradcorr_max=0.0d0
 771       gel_loc_max=0.0d0
 772       gcorr3_turn_max=0.0d0
 773       gcorr4_turn_max=0.0d0
 774       gradcorr5_max=0.0d0
 775       gradcorr6_max=0.0d0
 776       gcorr6_turn_max=0.0d0
 777       gsccorc_max=0.0d0
 778       gscloc_max=0.0d0
 779       gvdwx_max=0.0d0
 780       gradx_scp_max=0.0d0
 781       ghpbx_max=0.0d0
 782       gradxorr_max=0.0d0
 783       gsccorx_max=0.0d0
 784       gsclocx_max=0.0d0
 785       do i=1,nct
 786         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 787         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 788         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 789         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 790      &   gvdwc_scp_max=gvdwc_scp_norm
 791         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 792         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 793         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 794         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 795         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 796         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 797         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 798         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 799         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 800         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 801         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 802         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 803         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 804      &    gcorr3_turn(1,i)))
 805         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 806      &    gcorr3_turn_max=gcorr3_turn_norm
 807         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 808      &    gcorr4_turn(1,i)))
 809         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 810      &    gcorr4_turn_max=gcorr4_turn_norm
 811         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 812         if (gradcorr5_norm.gt.gradcorr5_max)
 813      &    gradcorr5_max=gradcorr5_norm
 814         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 815         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 816         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 817      &    gcorr6_turn(1,i)))
 818         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 819      &    gcorr6_turn_max=gcorr6_turn_norm
 820         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 821         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 822         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 823         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 824         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 825         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 826         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 827         if (gradx_scp_norm.gt.gradx_scp_max)
 828      &    gradx_scp_max=gradx_scp_norm
 829         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 830         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 831         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 832         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 833         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 834         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 835         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 836         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 837       enddo
 838       if (gradout) then
 839 #ifdef AIX
 840         open(istat,file=statname,position="append")
 841 #else
 842         open(istat,file=statname,access="append")
 843 #endif
 844         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 845      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 846      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 847      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 848      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 849      &     gsccorx_max,gsclocx_max
 850         close(istat)
 851         if (gvdwc_max.gt.1.0d4) then
 852           write (iout,*) "gvdwc gvdwx gradb gradbx"
 853           do i=nnt,nct
 854             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 855      &        gradb(j,i),gradbx(j,i),j=1,3)
 856           enddo
 857           call pdbout(0.0d0,'cipiszcze',iout)
 858           call flush(iout)
 859         endif
 860       endif
 861       endif
 862 #ifdef DEBUG
 863       write (iout,*) "gradc gradx gloc"
 864       do i=1,nres
 865         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 866      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 867       enddo
 868 #endif
 869 #ifdef TIMING
 870       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 871 #endif
 872       return
 873       end
 874 c-------------------------------------------------------------------------------
 875       subroutine rescale_weights(t_bath)
 876       implicit real*8 (a-h,o-z)
 877       include 'DIMENSIONS'
 878       include 'COMMON.IOUNITS'
 879       include 'COMMON.FFIELD'
 880       include 'COMMON.SBRIDGE'
 881       double precision kfac /2.4d0/
 882       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 883 c      facT=temp0/t_bath
 884 c      facT=2*temp0/(t_bath+temp0)
 885       if (rescale_mode.eq.0) then
 886         facT=1.0d0
 887         facT2=1.0d0
 888         facT3=1.0d0
 889         facT4=1.0d0
 890         facT5=1.0d0
 891       else if (rescale_mode.eq.1) then
 892         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 893         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 894         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 895         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 896         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 897       else if (rescale_mode.eq.2) then
 898         x=t_bath/temp0
 899         x2=x*x
 900         x3=x2*x
 901         x4=x3*x
 902         x5=x4*x
 903         facT=licznik/dlog(dexp(x)+dexp(-x))
 904         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 905         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 906         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 907         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 908       else
 909         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 910         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 911 #ifdef MPI
 912        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 913 #endif
 914        stop 555
 915       endif
 916       welec=weights(3)*fact
 917       wcorr=weights(4)*fact3
 918       wcorr5=weights(5)*fact4
 919       wcorr6=weights(6)*fact5
 920       wel_loc=weights(7)*fact2
 921       wturn3=weights(8)*fact2
 922       wturn4=weights(9)*fact3
 923       wturn6=weights(10)*fact5
 924       wtor=weights(13)*fact
 925       wtor_d=weights(14)*fact2
 926       wsccor=weights(21)*fact
 927
 928       return
 929       end
 930 C------------------------------------------------------------------------
 931       subroutine enerprint(energia)
 932       implicit real*8 (a-h,o-z)
 933       include 'DIMENSIONS'
 934       include 'COMMON.IOUNITS'
 935       include 'COMMON.FFIELD'
 936       include 'COMMON.SBRIDGE'
 937       include 'COMMON.MD'
 938       double precision energia(0:n_ene)
 939       etot=energia(0)
 940       evdw=energia(1)
 941       evdw2=energia(2)
 942 #ifdef SCP14
 943       evdw2=energia(2)+energia(18)
 944 #else
 945       evdw2=energia(2)
 946 #endif
 947       ees=energia(3)
 948 #ifdef SPLITELE
 949       evdw1=energia(16)
 950 #endif
 951       ecorr=energia(4)
 952       ecorr5=energia(5)
 953       ecorr6=energia(6)
 954       eel_loc=energia(7)
 955       eello_turn3=energia(8)
 956       eello_turn4=energia(9)
 957       eello_turn6=energia(10)
 958       ebe=energia(11)
 959       escloc=energia(12)
 960       etors=energia(13)
 961       etors_d=energia(14)
 962       ehpb=energia(15)
 963       edihcnstr=energia(19)
 964       estr=energia(17)
 965       Uconst=energia(20)
 966       esccor=energia(21)
 967 #ifdef SPLITELE
 968       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 969      &  estr,wbond,ebe,wang,
 970      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 971      &  ecorr,wcorr,
 972      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 973      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 974      &  edihcnstr,ebr*nss,
 975      &  Uconst,etot
 976    10 format (/'Virtual-chain energies:'//
 977      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 978      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 979      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 980      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 981      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 982      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 983      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 984      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 985      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 986      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 987      & ' (SS bridges & dist. cnstr.)'/
 988      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 989      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 990      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 991      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 992      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 993      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 994      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 995      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 996      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 997      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 998      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 999      & 'ETOT=  ',1pE16.6,' (total)')
1000 #else
1001       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1002      &  estr,wbond,ebe,wang,
1003      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1004      &  ecorr,wcorr,
1005      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1006      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1007      &  ebr*nss,Uconst,etot
1008    10 format (/'Virtual-chain energies:'//
1009      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1010      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1011      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1012      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1013      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1014      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1015      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1016      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1017      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1018      & ' (SS bridges & dist. cnstr.)'/
1019      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1020      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1021      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1022      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1023      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1024      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1025      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1026      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1027      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1028      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1029      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1030      & 'ETOT=  ',1pE16.6,' (total)')
1031 #endif
1032       return
1033       end
1034 C-----------------------------------------------------------------------
1035       subroutine elj(evdw)
1036 C
1037 C This subroutine calculates the interaction energy of nonbonded side chains
1038 C assuming the LJ potential of interaction.
1039 C
1040       implicit real*8 (a-h,o-z)
1041       include 'DIMENSIONS'
1042       parameter (accur=1.0d-10)
1043       include 'COMMON.GEO'
1044       include 'COMMON.VAR'
1045       include 'COMMON.LOCAL'
1046       include 'COMMON.CHAIN'
1047       include 'COMMON.DERIV'
1048       include 'COMMON.INTERACT'
1049       include 'COMMON.TORSION'
1050       include 'COMMON.SBRIDGE'
1051       include 'COMMON.NAMES'
1052       include 'COMMON.IOUNITS'
1053       include 'COMMON.CONTACTS'
1054       dimension gg(3)
1055 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1056       evdw=0.0D0
1057       do i=iatsc_s,iatsc_e
1058         itypi=iabs(itype(i))
1059         if (itypi.eq.ntyp1) cycle
1060         itypi1=iabs(itype(i+1))
1061         xi=c(1,nres+i)
1062         yi=c(2,nres+i)
1063         zi=c(3,nres+i)
1064 C Change 12/1/95
1065         num_conti=0
1066 C
1067 C Calculate SC interaction energy.
1068 C
1069         do iint=1,nint_gr(i)
1070 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1071 cd   &                  'iend=',iend(i,iint)
1072           do j=istart(i,iint),iend(i,iint)
1073             itypj=iabs(itype(j))
1074             if (itypj.eq.ntyp1) cycle
1075             xj=c(1,nres+j)-xi
1076             yj=c(2,nres+j)-yi
1077             zj=c(3,nres+j)-zi
1078 C Change 12/1/95 to calculate four-body interactions
1079             rij=xj*xj+yj*yj+zj*zj
1080             rrij=1.0D0/rij
1081 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1082             eps0ij=eps(itypi,itypj)
1083             fac=rrij**expon2
1084             e1=fac*fac*aa(itypi,itypj)
1085             e2=fac*bb(itypi,itypj)
1086             evdwij=e1+e2
1087 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1088 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1089 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1090 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1091 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1092 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1093             evdw=evdw+evdwij
1094 C
1095 C Calculate the components of the gradient in DC and X
1096 C
1097             fac=-rrij*(e1+evdwij)
1098             gg(1)=xj*fac
1099             gg(2)=yj*fac
1100             gg(3)=zj*fac
1101             do k=1,3
1102               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1103               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1104               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1105               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1106             enddo
1107 cgrad            do k=i,j-1
1108 cgrad              do l=1,3
1109 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1110 cgrad              enddo
1111 cgrad            enddo
1112 C
1113 C 12/1/95, revised on 5/20/97
1114 C
1115 C Calculate the contact function. The ith column of the array JCONT will
1116 C contain the numbers of atoms that make contacts with the atom I (of numbers
1117 C greater than I). The arrays FACONT and GACONT will contain the values of
1118 C the contact function and its derivative.
1119 C
1120 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1121 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1122 C Uncomment next line, if the correlation interactions are contact function only
1123             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1124               rij=dsqrt(rij)
1125               sigij=sigma(itypi,itypj)
1126               r0ij=rs0(itypi,itypj)
1127 C
1128 C Check whether the SC's are not too far to make a contact.
1129 C
1130               rcut=1.5d0*r0ij
1131               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1132 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1133 C
1134               if (fcont.gt.0.0D0) then
1135 C If the SC-SC distance if close to sigma, apply spline.
1136 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1137 cAdam &             fcont1,fprimcont1)
1138 cAdam           fcont1=1.0d0-fcont1
1139 cAdam           if (fcont1.gt.0.0d0) then
1140 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1141 cAdam             fcont=fcont*fcont1
1142 cAdam           endif
1143 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1144 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1145 cga             do k=1,3
1146 cga               gg(k)=gg(k)*eps0ij
1147 cga             enddo
1148 cga             eps0ij=-evdwij*eps0ij
1149 C Uncomment for AL's type of SC correlation interactions.
1150 cadam           eps0ij=-evdwij
1151                 num_conti=num_conti+1
1152                 jcont(num_conti,i)=j
1153                 facont(num_conti,i)=fcont*eps0ij
1154                 fprimcont=eps0ij*fprimcont/rij
1155                 fcont=expon*fcont
1156 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1157 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1158 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1159 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1160                 gacont(1,num_conti,i)=-fprimcont*xj
1161                 gacont(2,num_conti,i)=-fprimcont*yj
1162                 gacont(3,num_conti,i)=-fprimcont*zj
1163 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1164 cd              write (iout,'(2i3,3f10.5)')
1165 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1166               endif
1167             endif
1168           enddo      ! j
1169         enddo        ! iint
1170 C Change 12/1/95
1171         num_cont(i)=num_conti
1172       enddo          ! i
1173       do i=1,nct
1174         do j=1,3
1175           gvdwc(j,i)=expon*gvdwc(j,i)
1176           gvdwx(j,i)=expon*gvdwx(j,i)
1177         enddo
1178       enddo
1179 C******************************************************************************
1180 C
1181 C                              N O T E !!!
1182 C
1183 C To save time, the factor of EXPON has been extracted from ALL components
1184 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1185 C use!
1186 C
1187 C******************************************************************************
1188       return
1189       end
1190 C-----------------------------------------------------------------------------
1191       subroutine eljk(evdw)
1192 C
1193 C This subroutine calculates the interaction energy of nonbonded side chains
1194 C assuming the LJK potential of interaction.
1195 C
1196       implicit real*8 (a-h,o-z)
1197       include 'DIMENSIONS'
1198       include 'COMMON.GEO'
1199       include 'COMMON.VAR'
1200       include 'COMMON.LOCAL'
1201       include 'COMMON.CHAIN'
1202       include 'COMMON.DERIV'
1203       include 'COMMON.INTERACT'
1204       include 'COMMON.IOUNITS'
1205       include 'COMMON.NAMES'
1206       dimension gg(3)
1207       logical scheck
1208 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1209       evdw=0.0D0
1210       do i=iatsc_s,iatsc_e
1211         itypi=iabs(itype(i))
1212         if (itypi.eq.ntyp1) cycle
1213         itypi1=iabs(itype(i+1))
1214         xi=c(1,nres+i)
1215         yi=c(2,nres+i)
1216         zi=c(3,nres+i)
1217 C
1218 C Calculate SC interaction energy.
1219 C
1220         do iint=1,nint_gr(i)
1221           do j=istart(i,iint),iend(i,iint)
1222             itypj=iabs(itype(j))
1223             if (itypj.eq.ntyp1) cycle
1224             xj=c(1,nres+j)-xi
1225             yj=c(2,nres+j)-yi
1226             zj=c(3,nres+j)-zi
1227             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1228             fac_augm=rrij**expon
1229             e_augm=augm(itypi,itypj)*fac_augm
1230             r_inv_ij=dsqrt(rrij)
1231             rij=1.0D0/r_inv_ij
1232             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1233             fac=r_shift_inv**expon
1234             e1=fac*fac*aa(itypi,itypj)
1235             e2=fac*bb(itypi,itypj)
1236             evdwij=e_augm+e1+e2
1237 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1238 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1239 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1240 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1241 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1242 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1243 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1244             evdw=evdw+evdwij
1245 C
1246 C Calculate the components of the gradient in DC and X
1247 C
1248             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1249             gg(1)=xj*fac
1250             gg(2)=yj*fac
1251             gg(3)=zj*fac
1252             do k=1,3
1253               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1254               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1255               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1256               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1257             enddo
1258 cgrad            do k=i,j-1
1259 cgrad              do l=1,3
1260 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1261 cgrad              enddo
1262 cgrad            enddo
1263           enddo      ! j
1264         enddo        ! iint
1265       enddo          ! i
1266       do i=1,nct
1267         do j=1,3
1268           gvdwc(j,i)=expon*gvdwc(j,i)
1269           gvdwx(j,i)=expon*gvdwx(j,i)
1270         enddo
1271       enddo
1272       return
1273       end
1274 C-----------------------------------------------------------------------------
1275       subroutine ebp(evdw)
1276 C
1277 C This subroutine calculates the interaction energy of nonbonded side chains
1278 C assuming the Berne-Pechukas potential of interaction.
1279 C
1280       implicit real*8 (a-h,o-z)
1281       include 'DIMENSIONS'
1282       include 'COMMON.GEO'
1283       include 'COMMON.VAR'
1284       include 'COMMON.LOCAL'
1285       include 'COMMON.CHAIN'
1286       include 'COMMON.DERIV'
1287       include 'COMMON.NAMES'
1288       include 'COMMON.INTERACT'
1289       include 'COMMON.IOUNITS'
1290       include 'COMMON.CALC'
1291       common /srutu/ icall
1292 c     double precision rrsave(maxdim)
1293       logical lprn
1294       evdw=0.0D0
1295 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1296       evdw=0.0D0
1297 c     if (icall.eq.0) then
1298 c       lprn=.true.
1299 c     else
1300         lprn=.false.
1301 c     endif
1302       ind=0
1303       do i=iatsc_s,iatsc_e
1304         itypi=iabs(itype(i))
1305         if (itypi.eq.ntyp1) cycle
1306         itypi1=iabs(itype(i+1))
1307         xi=c(1,nres+i)
1308         yi=c(2,nres+i)
1309         zi=c(3,nres+i)
1310         dxi=dc_norm(1,nres+i)
1311         dyi=dc_norm(2,nres+i)
1312         dzi=dc_norm(3,nres+i)
1313 c        dsci_inv=dsc_inv(itypi)
1314         dsci_inv=vbld_inv(i+nres)
1315 C
1316 C Calculate SC interaction energy.
1317 C
1318         do iint=1,nint_gr(i)
1319           do j=istart(i,iint),iend(i,iint)
1320             ind=ind+1
1321             itypj=iabs(itype(j))
1322             if (itypj.eq.ntyp1) cycle
1323 c            dscj_inv=dsc_inv(itypj)
1324             dscj_inv=vbld_inv(j+nres)
1325             chi1=chi(itypi,itypj)
1326             chi2=chi(itypj,itypi)
1327             chi12=chi1*chi2
1328             chip1=chip(itypi)
1329             chip2=chip(itypj)
1330             chip12=chip1*chip2
1331             alf1=alp(itypi)
1332             alf2=alp(itypj)
1333             alf12=0.5D0*(alf1+alf2)
1334 C For diagnostics only!!!
1335 c           chi1=0.0D0
1336 c           chi2=0.0D0
1337 c           chi12=0.0D0
1338 c           chip1=0.0D0
1339 c           chip2=0.0D0
1340 c           chip12=0.0D0
1341 c           alf1=0.0D0
1342 c           alf2=0.0D0
1343 c           alf12=0.0D0
1344             xj=c(1,nres+j)-xi
1345             yj=c(2,nres+j)-yi
1346             zj=c(3,nres+j)-zi
1347             dxj=dc_norm(1,nres+j)
1348             dyj=dc_norm(2,nres+j)
1349             dzj=dc_norm(3,nres+j)
1350             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1351 cd          if (icall.eq.0) then
1352 cd            rrsave(ind)=rrij
1353 cd          else
1354 cd            rrij=rrsave(ind)
1355 cd          endif
1356             rij=dsqrt(rrij)
1357 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1358             call sc_angular
1359 C Calculate whole angle-dependent part of epsilon and contributions
1360 C to its derivatives
1361             fac=(rrij*sigsq)**expon2
1362             e1=fac*fac*aa(itypi,itypj)
1363             e2=fac*bb(itypi,itypj)
1364             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1365             eps2der=evdwij*eps3rt
1366             eps3der=evdwij*eps2rt
1367             evdwij=evdwij*eps2rt*eps3rt
1368             evdw=evdw+evdwij
1369             if (lprn) then
1370             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1371             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1372 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1373 cd     &        restyp(itypi),i,restyp(itypj),j,
1374 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1375 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1376 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1377 cd     &        evdwij
1378             endif
1379 C Calculate gradient components.
1380             e1=e1*eps1*eps2rt**2*eps3rt**2
1381             fac=-expon*(e1+evdwij)
1382             sigder=fac/sigsq
1383             fac=rrij*fac
1384 C Calculate radial part of the gradient
1385             gg(1)=xj*fac
1386             gg(2)=yj*fac
1387             gg(3)=zj*fac
1388 C Calculate the angular part of the gradient and sum add the contributions
1389 C to the appropriate components of the Cartesian gradient.
1390             call sc_grad
1391           enddo      ! j
1392         enddo        ! iint
1393       enddo          ! i
1394 c     stop
1395       return
1396       end
1397 C-----------------------------------------------------------------------------
1398       subroutine egb(evdw)
1399 C
1400 C This subroutine calculates the interaction energy of nonbonded side chains
1401 C assuming the Gay-Berne potential of interaction.
1402 C
1403       implicit real*8 (a-h,o-z)
1404       include 'DIMENSIONS'
1405       include 'COMMON.GEO'
1406       include 'COMMON.VAR'
1407       include 'COMMON.LOCAL'
1408       include 'COMMON.CHAIN'
1409       include 'COMMON.DERIV'
1410       include 'COMMON.NAMES'
1411       include 'COMMON.INTERACT'
1412       include 'COMMON.IOUNITS'
1413       include 'COMMON.CALC'
1414       include 'COMMON.CONTROL'
1415       logical lprn
1416       evdw=0.0D0
1417 ccccc      energy_dec=.false.
1418 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1419       evdw=0.0D0
1420       lprn=.false.
1421 c     if (icall.eq.0) lprn=.false.
1422       ind=0
1423       do i=iatsc_s,iatsc_e
1424         itypi=iabs(itype(i))
1425         if (itypi.eq.ntyp1) cycle
1426         itypi1=iabs(itype(i+1))
1427         xi=c(1,nres+i)
1428         yi=c(2,nres+i)
1429         zi=c(3,nres+i)
1430         dxi=dc_norm(1,nres+i)
1431         dyi=dc_norm(2,nres+i)
1432         dzi=dc_norm(3,nres+i)
1433 c        dsci_inv=dsc_inv(itypi)
1434         dsci_inv=vbld_inv(i+nres)
1435 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1436 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1437 C
1438 C Calculate SC interaction energy.
1439 C
1440         do iint=1,nint_gr(i)
1441           do j=istart(i,iint),iend(i,iint)
1442             ind=ind+1
1443             itypj=iabs(itype(j))
1444             if (itypj.eq.ntyp1) cycle
1445 c            dscj_inv=dsc_inv(itypj)
1446             dscj_inv=vbld_inv(j+nres)
1447 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1448 c     &       1.0d0/vbld(j+nres)
1449 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1450             sig0ij=sigma(itypi,itypj)
1451             chi1=chi(itypi,itypj)
1452             chi2=chi(itypj,itypi)
1453             chi12=chi1*chi2
1454             chip1=chip(itypi)
1455             chip2=chip(itypj)
1456             chip12=chip1*chip2
1457             alf1=alp(itypi)
1458             alf2=alp(itypj)
1459             alf12=0.5D0*(alf1+alf2)
1460 C For diagnostics only!!!
1461 c           chi1=0.0D0
1462 c           chi2=0.0D0
1463 c           chi12=0.0D0
1464 c           chip1=0.0D0
1465 c           chip2=0.0D0
1466 c           chip12=0.0D0
1467 c           alf1=0.0D0
1468 c           alf2=0.0D0
1469 c           alf12=0.0D0
1470             xj=c(1,nres+j)-xi
1471             yj=c(2,nres+j)-yi
1472             zj=c(3,nres+j)-zi
1473             dxj=dc_norm(1,nres+j)
1474             dyj=dc_norm(2,nres+j)
1475             dzj=dc_norm(3,nres+j)
1476 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1477 c            write (iout,*) "j",j," dc_norm",
1478 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1479             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1480             rij=dsqrt(rrij)
1481 C Calculate angle-dependent terms of energy and contributions to their
1482 C derivatives.
1483             call sc_angular
1484             sigsq=1.0D0/sigsq
1485             sig=sig0ij*dsqrt(sigsq)
1486             rij_shift=1.0D0/rij-sig+sig0ij
1487 c for diagnostics; uncomment
1488 c            rij_shift=1.2*sig0ij
1489 C I hate to put IF's in the loops, but here don't have another choice!!!!
1490             if (rij_shift.le.0.0D0) then
1491               evdw=1.0D20
1492 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1493 cd     &        restyp(itypi),i,restyp(itypj),j,
1494 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1495               return
1496             endif
1497             sigder=-sig*sigsq
1498 c---------------------------------------------------------------
1499             rij_shift=1.0D0/rij_shift
1500             fac=rij_shift**expon
1501             e1=fac*fac*aa(itypi,itypj)
1502             e2=fac*bb(itypi,itypj)
1503             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1504             eps2der=evdwij*eps3rt
1505             eps3der=evdwij*eps2rt
1506 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1507 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1508             evdwij=evdwij*eps2rt*eps3rt
1509             evdw=evdw+evdwij
1510             if (lprn) then
1511             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1512             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1513             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1514      &        restyp(itypi),i,restyp(itypj),j,
1515      &        epsi,sigm,chi1,chi2,chip1,chip2,
1516      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1517      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1518      &        evdwij
1519             endif
1520
1521             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1522      &                        'evdw',i,j,evdwij
1523
1524 C Calculate gradient components.
1525             e1=e1*eps1*eps2rt**2*eps3rt**2
1526             fac=-expon*(e1+evdwij)*rij_shift
1527             sigder=fac*sigder
1528             fac=rij*fac
1529 c            fac=0.0d0
1530 C Calculate the radial part of the gradient
1531             gg(1)=xj*fac
1532             gg(2)=yj*fac
1533             gg(3)=zj*fac
1534 C Calculate angular part of the gradient.
1535             call sc_grad
1536           enddo      ! j
1537         enddo        ! iint
1538       enddo          ! i
1539 c      write (iout,*) "Number of loop steps in EGB:",ind
1540 cccc      energy_dec=.false.
1541       return
1542       end
1543 C-----------------------------------------------------------------------------
1544       subroutine egbv(evdw)
1545 C
1546 C This subroutine calculates the interaction energy of nonbonded side chains
1547 C assuming the Gay-Berne-Vorobjev potential of interaction.
1548 C
1549       implicit real*8 (a-h,o-z)
1550       include 'DIMENSIONS'
1551       include 'COMMON.GEO'
1552       include 'COMMON.VAR'
1553       include 'COMMON.LOCAL'
1554       include 'COMMON.CHAIN'
1555       include 'COMMON.DERIV'
1556       include 'COMMON.NAMES'
1557       include 'COMMON.INTERACT'
1558       include 'COMMON.IOUNITS'
1559       include 'COMMON.CALC'
1560       common /srutu/ icall
1561       logical lprn
1562       evdw=0.0D0
1563 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1564       evdw=0.0D0
1565       lprn=.false.
1566 c     if (icall.eq.0) lprn=.true.
1567       ind=0
1568       do i=iatsc_s,iatsc_e
1569         itypi=iabs(itype(i))
1570         if (itypi.eq.ntyp1) cycle
1571         itypi1=iabs(itype(i+1))
1572         xi=c(1,nres+i)
1573         yi=c(2,nres+i)
1574         zi=c(3,nres+i)
1575         dxi=dc_norm(1,nres+i)
1576         dyi=dc_norm(2,nres+i)
1577         dzi=dc_norm(3,nres+i)
1578 c        dsci_inv=dsc_inv(itypi)
1579         dsci_inv=vbld_inv(i+nres)
1580 C
1581 C Calculate SC interaction energy.
1582 C
1583         do iint=1,nint_gr(i)
1584           do j=istart(i,iint),iend(i,iint)
1585             ind=ind+1
1586             itypj=iabs(itype(j))
1587             if (itypj.eq.ntyp1) cycle
1588 c            dscj_inv=dsc_inv(itypj)
1589             dscj_inv=vbld_inv(j+nres)
1590             sig0ij=sigma(itypi,itypj)
1591             r0ij=r0(itypi,itypj)
1592             chi1=chi(itypi,itypj)
1593             chi2=chi(itypj,itypi)
1594             chi12=chi1*chi2
1595             chip1=chip(itypi)
1596             chip2=chip(itypj)
1597             chip12=chip1*chip2
1598             alf1=alp(itypi)
1599             alf2=alp(itypj)
1600             alf12=0.5D0*(alf1+alf2)
1601 C For diagnostics only!!!
1602 c           chi1=0.0D0
1603 c           chi2=0.0D0
1604 c           chi12=0.0D0
1605 c           chip1=0.0D0
1606 c           chip2=0.0D0
1607 c           chip12=0.0D0
1608 c           alf1=0.0D0
1609 c           alf2=0.0D0
1610 c           alf12=0.0D0
1611             xj=c(1,nres+j)-xi
1612             yj=c(2,nres+j)-yi
1613             zj=c(3,nres+j)-zi
1614             dxj=dc_norm(1,nres+j)
1615             dyj=dc_norm(2,nres+j)
1616             dzj=dc_norm(3,nres+j)
1617             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1618             rij=dsqrt(rrij)
1619 C Calculate angle-dependent terms of energy and contributions to their
1620 C derivatives.
1621             call sc_angular
1622             sigsq=1.0D0/sigsq
1623             sig=sig0ij*dsqrt(sigsq)
1624             rij_shift=1.0D0/rij-sig+r0ij
1625 C I hate to put IF's in the loops, but here don't have another choice!!!!
1626             if (rij_shift.le.0.0D0) then
1627               evdw=1.0D20
1628               return
1629             endif
1630             sigder=-sig*sigsq
1631 c---------------------------------------------------------------
1632             rij_shift=1.0D0/rij_shift
1633             fac=rij_shift**expon
1634             e1=fac*fac*aa(itypi,itypj)
1635             e2=fac*bb(itypi,itypj)
1636             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1637             eps2der=evdwij*eps3rt
1638             eps3der=evdwij*eps2rt
1639             fac_augm=rrij**expon
1640             e_augm=augm(itypi,itypj)*fac_augm
1641             evdwij=evdwij*eps2rt*eps3rt
1642             evdw=evdw+evdwij+e_augm
1643             if (lprn) then
1644             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1645             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1646             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1647      &        restyp(itypi),i,restyp(itypj),j,
1648      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1649      &        chi1,chi2,chip1,chip2,
1650      &        eps1,eps2rt**2,eps3rt**2,
1651      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1652      &        evdwij+e_augm
1653             endif
1654 C Calculate gradient components.
1655             e1=e1*eps1*eps2rt**2*eps3rt**2
1656             fac=-expon*(e1+evdwij)*rij_shift
1657             sigder=fac*sigder
1658             fac=rij*fac-2*expon*rrij*e_augm
1659 C Calculate the radial part of the gradient
1660             gg(1)=xj*fac
1661             gg(2)=yj*fac
1662             gg(3)=zj*fac
1663 C Calculate angular part of the gradient.
1664             call sc_grad
1665           enddo      ! j
1666         enddo        ! iint
1667       enddo          ! i
1668       end
1669 C-----------------------------------------------------------------------------
1670       subroutine sc_angular
1671 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1672 C om12. Called by ebp, egb, and egbv.
1673       implicit none
1674       include 'COMMON.CALC'
1675       include 'COMMON.IOUNITS'
1676       erij(1)=xj*rij
1677       erij(2)=yj*rij
1678       erij(3)=zj*rij
1679       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1680       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1681       om12=dxi*dxj+dyi*dyj+dzi*dzj
1682       chiom12=chi12*om12
1683 C Calculate eps1(om12) and its derivative in om12
1684       faceps1=1.0D0-om12*chiom12
1685       faceps1_inv=1.0D0/faceps1
1686       eps1=dsqrt(faceps1_inv)
1687 C Following variable is eps1*deps1/dom12
1688       eps1_om12=faceps1_inv*chiom12
1689 c diagnostics only
1690 c      faceps1_inv=om12
1691 c      eps1=om12
1692 c      eps1_om12=1.0d0
1693 c      write (iout,*) "om12",om12," eps1",eps1
1694 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1695 C and om12.
1696       om1om2=om1*om2
1697       chiom1=chi1*om1
1698       chiom2=chi2*om2
1699       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1700       sigsq=1.0D0-facsig*faceps1_inv
1701       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1702       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1703       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1704 c diagnostics only
1705 c      sigsq=1.0d0
1706 c      sigsq_om1=0.0d0
1707 c      sigsq_om2=0.0d0
1708 c      sigsq_om12=0.0d0
1709 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1710 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1711 c     &    " eps1",eps1
1712 C Calculate eps2 and its derivatives in om1, om2, and om12.
1713       chipom1=chip1*om1
1714       chipom2=chip2*om2
1715       chipom12=chip12*om12
1716       facp=1.0D0-om12*chipom12
1717       facp_inv=1.0D0/facp
1718       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1719 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1720 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1721 C Following variable is the square root of eps2
1722       eps2rt=1.0D0-facp1*facp_inv
1723 C Following three variables are the derivatives of the square root of eps
1724 C in om1, om2, and om12.
1725       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1726       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1727       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1728 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1729       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1730 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1731 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1732 c     &  " eps2rt_om12",eps2rt_om12
1733 C Calculate whole angle-dependent part of epsilon and contributions
1734 C to its derivatives
1735       return
1736       end
1737 C----------------------------------------------------------------------------
1738       subroutine sc_grad
1739       implicit real*8 (a-h,o-z)
1740       include 'DIMENSIONS'
1741       include 'COMMON.CHAIN'
1742       include 'COMMON.DERIV'
1743       include 'COMMON.CALC'
1744       include 'COMMON.IOUNITS'
1745       double precision dcosom1(3),dcosom2(3)
1746       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1747       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1748       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1749      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1750 c diagnostics only
1751 c      eom1=0.0d0
1752 c      eom2=0.0d0
1753 c      eom12=evdwij*eps1_om12
1754 c end diagnostics
1755 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1756 c     &  " sigder",sigder
1757 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1758 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1759       do k=1,3
1760         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1761         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1762       enddo
1763       do k=1,3
1764         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1765       enddo
1766 c      write (iout,*) "gg",(gg(k),k=1,3)
1767       do k=1,3
1768         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1769      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1770      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1771         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1772      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1773      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1774 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1775 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1776 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1777 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1778       enddo
1779 C
1780 C Calculate the components of the gradient in DC and X
1781 C
1782 cgrad      do k=i,j-1
1783 cgrad        do l=1,3
1784 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1785 cgrad        enddo
1786 cgrad      enddo
1787       do l=1,3
1788         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1789         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1790       enddo
1791       return
1792       end
1793 C-----------------------------------------------------------------------
1794       subroutine e_softsphere(evdw)
1795 C
1796 C This subroutine calculates the interaction energy of nonbonded side chains
1797 C assuming the LJ potential of interaction.
1798 C
1799       implicit real*8 (a-h,o-z)
1800       include 'DIMENSIONS'
1801       parameter (accur=1.0d-10)
1802       include 'COMMON.GEO'
1803       include 'COMMON.VAR'
1804       include 'COMMON.LOCAL'
1805       include 'COMMON.CHAIN'
1806       include 'COMMON.DERIV'
1807       include 'COMMON.INTERACT'
1808       include 'COMMON.TORSION'
1809       include 'COMMON.SBRIDGE'
1810       include 'COMMON.NAMES'
1811       include 'COMMON.IOUNITS'
1812       include 'COMMON.CONTACTS'
1813       dimension gg(3)
1814 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1815       evdw=0.0D0
1816       do i=iatsc_s,iatsc_e
1817         itypi=iabs(itype(i))
1818         if (itypi.eq.ntyp1) cycle
1819         itypi1=iabs(itype(i+1))
1820         xi=c(1,nres+i)
1821         yi=c(2,nres+i)
1822         zi=c(3,nres+i)
1823 C
1824 C Calculate SC interaction energy.
1825 C
1826         do iint=1,nint_gr(i)
1827 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1828 cd   &                  'iend=',iend(i,iint)
1829           do j=istart(i,iint),iend(i,iint)
1830             itypj=iabs(itype(j))
1831             if (itypj.eq.ntyp1) cycle
1832             xj=c(1,nres+j)-xi
1833             yj=c(2,nres+j)-yi
1834             zj=c(3,nres+j)-zi
1835             rij=xj*xj+yj*yj+zj*zj
1836 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1837             r0ij=r0(itypi,itypj)
1838             r0ijsq=r0ij*r0ij
1839 c            print *,i,j,r0ij,dsqrt(rij)
1840             if (rij.lt.r0ijsq) then
1841               evdwij=0.25d0*(rij-r0ijsq)**2
1842               fac=rij-r0ijsq
1843             else
1844               evdwij=0.0d0
1845               fac=0.0d0
1846             endif
1847             evdw=evdw+evdwij
1848 C
1849 C Calculate the components of the gradient in DC and X
1850 C
1851             gg(1)=xj*fac
1852             gg(2)=yj*fac
1853             gg(3)=zj*fac
1854             do k=1,3
1855               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1856               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1857               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1858               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1859             enddo
1860 cgrad            do k=i,j-1
1861 cgrad              do l=1,3
1862 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1863 cgrad              enddo
1864 cgrad            enddo
1865           enddo ! j
1866         enddo ! iint
1867       enddo ! i
1868       return
1869       end
1870 C--------------------------------------------------------------------------
1871       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1872      &              eello_turn4)
1873 C
1874 C Soft-sphere potential of p-p interaction
1875 C
1876       implicit real*8 (a-h,o-z)
1877       include 'DIMENSIONS'
1878       include 'COMMON.CONTROL'
1879       include 'COMMON.IOUNITS'
1880       include 'COMMON.GEO'
1881       include 'COMMON.VAR'
1882       include 'COMMON.LOCAL'
1883       include 'COMMON.CHAIN'
1884       include 'COMMON.DERIV'
1885       include 'COMMON.INTERACT'
1886       include 'COMMON.CONTACTS'
1887       include 'COMMON.TORSION'
1888       include 'COMMON.VECTORS'
1889       include 'COMMON.FFIELD'
1890       dimension ggg(3)
1891 cd      write(iout,*) 'In EELEC_soft_sphere'
1892       ees=0.0D0
1893       evdw1=0.0D0
1894       eel_loc=0.0d0
1895       eello_turn3=0.0d0
1896       eello_turn4=0.0d0
1897       ind=0
1898       do i=iatel_s,iatel_e
1899         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1900         dxi=dc(1,i)
1901         dyi=dc(2,i)
1902         dzi=dc(3,i)
1903         xmedi=c(1,i)+0.5d0*dxi
1904         ymedi=c(2,i)+0.5d0*dyi
1905         zmedi=c(3,i)+0.5d0*dzi
1906         num_conti=0
1907 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1908         do j=ielstart(i),ielend(i)
1909           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1910           ind=ind+1
1911           iteli=itel(i)
1912           itelj=itel(j)
1913           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1914           r0ij=rpp(iteli,itelj)
1915           r0ijsq=r0ij*r0ij
1916           dxj=dc(1,j)
1917           dyj=dc(2,j)
1918           dzj=dc(3,j)
1919           xj=c(1,j)+0.5D0*dxj-xmedi
1920           yj=c(2,j)+0.5D0*dyj-ymedi
1921           zj=c(3,j)+0.5D0*dzj-zmedi
1922           rij=xj*xj+yj*yj+zj*zj
1923           if (rij.lt.r0ijsq) then
1924             evdw1ij=0.25d0*(rij-r0ijsq)**2
1925             fac=rij-r0ijsq
1926           else
1927             evdw1ij=0.0d0
1928             fac=0.0d0
1929           endif
1930           evdw1=evdw1+evdw1ij
1931 C
1932 C Calculate contributions to the Cartesian gradient.
1933 C
1934           ggg(1)=fac*xj
1935           ggg(2)=fac*yj
1936           ggg(3)=fac*zj
1937           do k=1,3
1938             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1939             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1940           enddo
1941 *
1942 * Loop over residues i+1 thru j-1.
1943 *
1944 cgrad          do k=i+1,j-1
1945 cgrad            do l=1,3
1946 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1947 cgrad            enddo
1948 cgrad          enddo
1949         enddo ! j
1950       enddo   ! i
1951 cgrad      do i=nnt,nct-1
1952 cgrad        do k=1,3
1953 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1954 cgrad        enddo
1955 cgrad        do j=i+1,nct-1
1956 cgrad          do k=1,3
1957 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1958 cgrad          enddo
1959 cgrad        enddo
1960 cgrad      enddo
1961       return
1962       end
1963 c------------------------------------------------------------------------------
1964       subroutine vec_and_deriv
1965       implicit real*8 (a-h,o-z)
1966       include 'DIMENSIONS'
1967 #ifdef MPI
1968       include 'mpif.h'
1969 #endif
1970       include 'COMMON.IOUNITS'
1971       include 'COMMON.GEO'
1972       include 'COMMON.VAR'
1973       include 'COMMON.LOCAL'
1974       include 'COMMON.CHAIN'
1975       include 'COMMON.VECTORS'
1976       include 'COMMON.SETUP'
1977       include 'COMMON.TIME1'
1978       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1979 C Compute the local reference systems. For reference system (i), the
1980 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1981 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1982 #ifdef PARVEC
1983       do i=ivec_start,ivec_end
1984 #else
1985       do i=1,nres-1
1986 #endif
1987           if (i.eq.nres-1) then
1988 C Case of the last full residue
1989 C Compute the Z-axis
1990             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1991             costh=dcos(pi-theta(nres))
1992             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1993             do k=1,3
1994               uz(k,i)=fac*uz(k,i)
1995             enddo
1996 C Compute the derivatives of uz
1997             uzder(1,1,1)= 0.0d0
1998             uzder(2,1,1)=-dc_norm(3,i-1)
1999             uzder(3,1,1)= dc_norm(2,i-1)
2000             uzder(1,2,1)= dc_norm(3,i-1)
2001             uzder(2,2,1)= 0.0d0
2002             uzder(3,2,1)=-dc_norm(1,i-1)
2003             uzder(1,3,1)=-dc_norm(2,i-1)
2004             uzder(2,3,1)= dc_norm(1,i-1)
2005             uzder(3,3,1)= 0.0d0
2006             uzder(1,1,2)= 0.0d0
2007             uzder(2,1,2)= dc_norm(3,i)
2008             uzder(3,1,2)=-dc_norm(2,i)
2009             uzder(1,2,2)=-dc_norm(3,i)
2010             uzder(2,2,2)= 0.0d0
2011             uzder(3,2,2)= dc_norm(1,i)
2012             uzder(1,3,2)= dc_norm(2,i)
2013             uzder(2,3,2)=-dc_norm(1,i)
2014             uzder(3,3,2)= 0.0d0
2015 C Compute the Y-axis
2016             facy=fac
2017             do k=1,3
2018               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2019             enddo
2020 C Compute the derivatives of uy
2021             do j=1,3
2022               do k=1,3
2023                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2024      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2025                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2026               enddo
2027               uyder(j,j,1)=uyder(j,j,1)-costh
2028               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2029             enddo
2030             do j=1,2
2031               do k=1,3
2032                 do l=1,3
2033                   uygrad(l,k,j,i)=uyder(l,k,j)
2034                   uzgrad(l,k,j,i)=uzder(l,k,j)
2035                 enddo
2036               enddo
2037             enddo
2038             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2039             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2040             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2041             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2042           else
2043 C Other residues
2044 C Compute the Z-axis
2045             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2046             costh=dcos(pi-theta(i+2))
2047             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2048             do k=1,3
2049               uz(k,i)=fac*uz(k,i)
2050             enddo
2051 C Compute the derivatives of uz
2052             uzder(1,1,1)= 0.0d0
2053             uzder(2,1,1)=-dc_norm(3,i+1)
2054             uzder(3,1,1)= dc_norm(2,i+1)
2055             uzder(1,2,1)= dc_norm(3,i+1)
2056             uzder(2,2,1)= 0.0d0
2057             uzder(3,2,1)=-dc_norm(1,i+1)
2058             uzder(1,3,1)=-dc_norm(2,i+1)
2059             uzder(2,3,1)= dc_norm(1,i+1)
2060             uzder(3,3,1)= 0.0d0
2061             uzder(1,1,2)= 0.0d0
2062             uzder(2,1,2)= dc_norm(3,i)
2063             uzder(3,1,2)=-dc_norm(2,i)
2064             uzder(1,2,2)=-dc_norm(3,i)
2065             uzder(2,2,2)= 0.0d0
2066             uzder(3,2,2)= dc_norm(1,i)
2067             uzder(1,3,2)= dc_norm(2,i)
2068             uzder(2,3,2)=-dc_norm(1,i)
2069             uzder(3,3,2)= 0.0d0
2070 C Compute the Y-axis
2071             facy=fac
2072             do k=1,3
2073               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2074             enddo
2075 C Compute the derivatives of uy
2076             do j=1,3
2077               do k=1,3
2078                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2079      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2080                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2081               enddo
2082               uyder(j,j,1)=uyder(j,j,1)-costh
2083               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2084             enddo
2085             do j=1,2
2086               do k=1,3
2087                 do l=1,3
2088                   uygrad(l,k,j,i)=uyder(l,k,j)
2089                   uzgrad(l,k,j,i)=uzder(l,k,j)
2090                 enddo
2091               enddo
2092             enddo
2093             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2094             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2095             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2096             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2097           endif
2098       enddo
2099       do i=1,nres-1
2100         vbld_inv_temp(1)=vbld_inv(i+1)
2101         if (i.lt.nres-1) then
2102           vbld_inv_temp(2)=vbld_inv(i+2)
2103           else
2104           vbld_inv_temp(2)=vbld_inv(i)
2105           endif
2106         do j=1,2
2107           do k=1,3
2108             do l=1,3
2109               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2110               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2111             enddo
2112           enddo
2113         enddo
2114       enddo
2115 #if defined(PARVEC) && defined(MPI)
2116       if (nfgtasks1.gt.1) then
2117         time00=MPI_Wtime()
2118 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2119 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2120 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2121         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2122      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2123      &   FG_COMM1,IERR)
2124         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2125      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2126      &   FG_COMM1,IERR)
2127         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2128      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2129      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2130         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2131      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2132      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2133         time_gather=time_gather+MPI_Wtime()-time00
2134       endif
2135 c      if (fg_rank.eq.0) then
2136 c        write (iout,*) "Arrays UY and UZ"
2137 c        do i=1,nres-1
2138 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2139 c     &     (uz(k,i),k=1,3)
2140 c        enddo
2141 c      endif
2142 #endif
2143       return
2144       end
2145 C-----------------------------------------------------------------------------
2146       subroutine check_vecgrad
2147       implicit real*8 (a-h,o-z)
2148       include 'DIMENSIONS'
2149       include 'COMMON.IOUNITS'
2150       include 'COMMON.GEO'
2151       include 'COMMON.VAR'
2152       include 'COMMON.LOCAL'
2153       include 'COMMON.CHAIN'
2154       include 'COMMON.VECTORS'
2155       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2156       dimension uyt(3,maxres),uzt(3,maxres)
2157       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2158       double precision delta /1.0d-7/
2159       call vec_and_deriv
2160 cd      do i=1,nres
2161 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2162 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2163 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2164 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2165 cd     &     (dc_norm(if90,i),if90=1,3)
2166 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2167 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2168 cd          write(iout,'(a)')
2169 cd      enddo
2170       do i=1,nres
2171         do j=1,2
2172           do k=1,3
2173             do l=1,3
2174               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2175               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2176             enddo
2177           enddo
2178         enddo
2179       enddo
2180       call vec_and_deriv
2181       do i=1,nres
2182         do j=1,3
2183           uyt(j,i)=uy(j,i)
2184           uzt(j,i)=uz(j,i)
2185         enddo
2186       enddo
2187       do i=1,nres
2188 cd        write (iout,*) 'i=',i
2189         do k=1,3
2190           erij(k)=dc_norm(k,i)
2191         enddo
2192         do j=1,3
2193           do k=1,3
2194             dc_norm(k,i)=erij(k)
2195           enddo
2196           dc_norm(j,i)=dc_norm(j,i)+delta
2197 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2198 c          do k=1,3
2199 c            dc_norm(k,i)=dc_norm(k,i)/fac
2200 c          enddo
2201 c          write (iout,*) (dc_norm(k,i),k=1,3)
2202 c          write (iout,*) (erij(k),k=1,3)
2203           call vec_and_deriv
2204           do k=1,3
2205             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2206             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2207             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2208             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2209           enddo
2210 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2211 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2212 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2213         enddo
2214         do k=1,3
2215           dc_norm(k,i)=erij(k)
2216         enddo
2217 cd        do k=1,3
2218 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2219 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2220 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2221 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2222 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2223 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2224 cd          write (iout,'(a)')
2225 cd        enddo
2226       enddo
2227       return
2228       end
2229 C--------------------------------------------------------------------------
2230       subroutine set_matrices
2231       implicit real*8 (a-h,o-z)
2232       include 'DIMENSIONS'
2233 #ifdef MPI
2234       include "mpif.h"
2235       include "COMMON.SETUP"
2236       integer IERR
2237       integer status(MPI_STATUS_SIZE)
2238 #endif
2239       include 'COMMON.IOUNITS'
2240       include 'COMMON.GEO'
2241       include 'COMMON.VAR'
2242       include 'COMMON.LOCAL'
2243       include 'COMMON.CHAIN'
2244       include 'COMMON.DERIV'
2245       include 'COMMON.INTERACT'
2246       include 'COMMON.CONTACTS'
2247       include 'COMMON.TORSION'
2248       include 'COMMON.VECTORS'
2249       include 'COMMON.FFIELD'
2250       double precision auxvec(2),auxmat(2,2)
2251 C
2252 C Compute the virtual-bond-torsional-angle dependent quantities needed
2253 C to calculate the el-loc multibody terms of various order.
2254 C
2255       write(iout,*) 'nphi=',nphi,nres
2256 #ifdef PARMAT
2257       do i=ivec_start+2,ivec_end+2
2258 #else
2259       do i=3,nres+1
2260 #endif
2261 #ifdef NEWCORR
2262         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2263           iti = itortyp(itype(i-2))
2264         else
2265           iti=ntortyp+1
2266         endif
2267 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2268         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2269           iti1 = itortyp(itype(i-1))
2270         else
2271           iti1=ntortyp+1
2272         endif
2273         write(iout,*),i
2274         b1(1,i-2)=bnew1(1,1,iti)*sin(theta(i-1)/2.0)
2275      &           +bnew1(2,1,iti)*sin(theta(i-1))
2276      &           +bnew1(3,1,iti)*cos(theta(i-1)/2.0)
2277         gtb1(1,i-2)=bnew1(1,1,iti)*cos(theta(i-1)/2.0)/2.0
2278      &             +bnew1(2,1,iti)*cos(theta(i-1))
2279      &             -bnew1(3,1,iti)*sin(theta(i-1)/2.0)/2.0
2280 c     &           +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2281 c     &*(cos(theta(i)/2.0)
2282         b2(1,i-2)=bnew2(1,1,iti)*sin(theta(i-1)/2.0)
2283      &           +bnew2(2,1,iti)*sin(theta(i-1))
2284      &           +bnew2(3,1,iti)*cos(theta(i-1)/2.0)
2285 c     &           +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2286 c     &*(cos(theta(i)/2.0)
2287         gtb2(1,i-2)=bnew2(1,1,iti)*cos(theta(i-1)/2.0)/2.0
2288      &             +bnew2(2,1,iti)*cos(theta(i-1))
2289      &             -bnew2(3,1,iti)*sin(theta(i-1)/2.0)/2.0
2290 c        if (ggb1(1,i).eq.0.0d0) then
2291 c        write(iout,*) 'i=',i,ggb1(1,i),
2292 c     &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2293 c     &bnew1(2,1,iti)*cos(theta(i)),
2294 c     &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2295 c        endif
2296         b1(2,i-2)=bnew1(1,2,iti)
2297         gtb1(2,i-2)=0.0
2298         b2(2,i-2)=bnew2(1,2,iti)
2299         gtb2(2,i-2)=0.0
2300 c        EE(1,1,iti)=0.0d0
2301 c        EE(2,2,iti)=0.0d0
2302 c        EE(1,2,iti)=0.5d0*eenew(1,iti)
2303 c        EE(2,1,iti)=0.5d0*eenew(1,iti)
2304 c        b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2305 c        b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2306        b1tilde(1,i-2)=b1(1,i-2)
2307        b1tilde(2,i-2)=-b1(2,i-2)
2308        b2tilde(1,i-2)=b2(1,i-2)
2309        b2tilde(2,i-2)=-b2(2,i-2)
2310        write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2311        write (iout,*) 'theta=', theta(i-1)
2312        enddo
2313 #ifdef PARMAT
2314       do i=ivec_start+2,ivec_end+2
2315 #else
2316       do i=3,nres+1
2317 #endif
2318 #endif
2319         if (i .lt. nres+1) then
2320           sin1=dsin(phi(i))
2321           cos1=dcos(phi(i))
2322           sintab(i-2)=sin1
2323           costab(i-2)=cos1
2324           obrot(1,i-2)=cos1
2325           obrot(2,i-2)=sin1
2326           sin2=dsin(2*phi(i))
2327           cos2=dcos(2*phi(i))
2328           sintab2(i-2)=sin2
2329           costab2(i-2)=cos2
2330           obrot2(1,i-2)=cos2
2331           obrot2(2,i-2)=sin2
2332           Ug(1,1,i-2)=-cos1
2333           Ug(1,2,i-2)=-sin1
2334           Ug(2,1,i-2)=-sin1
2335           Ug(2,2,i-2)= cos1
2336           Ug2(1,1,i-2)=-cos2
2337           Ug2(1,2,i-2)=-sin2
2338           Ug2(2,1,i-2)=-sin2
2339           Ug2(2,2,i-2)= cos2
2340         else
2341           costab(i-2)=1.0d0
2342           sintab(i-2)=0.0d0
2343           obrot(1,i-2)=1.0d0
2344           obrot(2,i-2)=0.0d0
2345           obrot2(1,i-2)=0.0d0
2346           obrot2(2,i-2)=0.0d0
2347           Ug(1,1,i-2)=1.0d0
2348           Ug(1,2,i-2)=0.0d0
2349           Ug(2,1,i-2)=0.0d0
2350           Ug(2,2,i-2)=1.0d0
2351           Ug2(1,1,i-2)=0.0d0
2352           Ug2(1,2,i-2)=0.0d0
2353           Ug2(2,1,i-2)=0.0d0
2354           Ug2(2,2,i-2)=0.0d0
2355         endif
2356         if (i .gt. 3 .and. i .lt. nres+1) then
2357           obrot_der(1,i-2)=-sin1
2358           obrot_der(2,i-2)= cos1
2359           Ugder(1,1,i-2)= sin1
2360           Ugder(1,2,i-2)=-cos1
2361           Ugder(2,1,i-2)=-cos1
2362           Ugder(2,2,i-2)=-sin1
2363           dwacos2=cos2+cos2
2364           dwasin2=sin2+sin2
2365           obrot2_der(1,i-2)=-dwasin2
2366           obrot2_der(2,i-2)= dwacos2
2367           Ug2der(1,1,i-2)= dwasin2
2368           Ug2der(1,2,i-2)=-dwacos2
2369           Ug2der(2,1,i-2)=-dwacos2
2370           Ug2der(2,2,i-2)=-dwasin2
2371         else
2372           obrot_der(1,i-2)=0.0d0
2373           obrot_der(2,i-2)=0.0d0
2374           Ugder(1,1,i-2)=0.0d0
2375           Ugder(1,2,i-2)=0.0d0
2376           Ugder(2,1,i-2)=0.0d0
2377           Ugder(2,2,i-2)=0.0d0
2378           obrot2_der(1,i-2)=0.0d0
2379           obrot2_der(2,i-2)=0.0d0
2380           Ug2der(1,1,i-2)=0.0d0
2381           Ug2der(1,2,i-2)=0.0d0
2382           Ug2der(2,1,i-2)=0.0d0
2383           Ug2der(2,2,i-2)=0.0d0
2384         endif
2385 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2386 #ifndef NEWCORR
2387         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2388           iti = itortyp(itype(i-2))
2389         else
2390           iti=ntortyp+1
2391         endif
2392 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2393         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2394           iti1 = itortyp(itype(i-1))
2395         else
2396           iti1=ntortyp+1
2397         endif
2398 #endif
2399 cd        write (iout,*) '*******i',i,' iti1',iti
2400 cd        write (iout,*) 'b1',b1(:,iti)
2401 cd        write (iout,*) 'b2',b2(:,iti)
2402 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2403 c        if (i .gt. iatel_s+2) then
2404         if (i .gt. nnt+2) then
2405           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2406 #ifdef NEWCORR
2407           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2408 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2409 #endif
2410           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2411           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2412      &    then
2413           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2414           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2415           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2416           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2417           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2418           endif
2419         else
2420           do k=1,2
2421             Ub2(k,i-2)=0.0d0
2422             Ctobr(k,i-2)=0.0d0
2423             Dtobr2(k,i-2)=0.0d0
2424             do l=1,2
2425               EUg(l,k,i-2)=0.0d0
2426               CUg(l,k,i-2)=0.0d0
2427               DUg(l,k,i-2)=0.0d0
2428               DtUg2(l,k,i-2)=0.0d0
2429             enddo
2430           enddo
2431         endif
2432         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2433         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2434         do k=1,2
2435           muder(k,i-2)=Ub2der(k,i-2)
2436         enddo
2437 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2438         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2439           if (itype(i-1).le.ntyp) then
2440             iti1 = itortyp(itype(i-1))
2441           else
2442             iti1=ntortyp+1
2443           endif
2444         else
2445           iti1=ntortyp+1
2446         endif
2447         do k=1,2
2448           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
2449         enddo
2450 cd        write (iout,*) 'mu ',mu(:,i-2)
2451 cd        write (iout,*) 'mu1',mu1(:,i-2)
2452 cd        write (iout,*) 'mu2',mu2(:,i-2)
2453         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2454      &  then
2455         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2456         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2457         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2458         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2459         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2460 C Vectors and matrices dependent on a single virtual-bond dihedral.
2461         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
2462         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2463         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2464         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2465         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2466         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2467         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2468         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2469         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2470         endif
2471       enddo
2472 C Matrices dependent on two consecutive virtual-bond dihedrals.
2473 C The order of matrices is from left to right.
2474       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2475      &then
2476 c      do i=max0(ivec_start,2),ivec_end
2477       do i=2,nres-1
2478         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2479         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2480         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2481         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2482         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2483         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2484         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2485         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2486       enddo
2487       endif
2488 #if defined(MPI) && defined(PARMAT)
2489 #ifdef DEBUG
2490 c      if (fg_rank.eq.0) then
2491         write (iout,*) "Arrays UG and UGDER before GATHER"
2492         do i=1,nres-1
2493           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2494      &     ((ug(l,k,i),l=1,2),k=1,2),
2495      &     ((ugder(l,k,i),l=1,2),k=1,2)
2496         enddo
2497         write (iout,*) "Arrays UG2 and UG2DER"
2498         do i=1,nres-1
2499           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2500      &     ((ug2(l,k,i),l=1,2),k=1,2),
2501      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2502         enddo
2503         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2504         do i=1,nres-1
2505           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2506      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2507      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2508         enddo
2509         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2510         do i=1,nres-1
2511           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2512      &     costab(i),sintab(i),costab2(i),sintab2(i)
2513         enddo
2514         write (iout,*) "Array MUDER"
2515         do i=1,nres-1
2516           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2517         enddo
2518 c      endif
2519 #endif
2520       if (nfgtasks.gt.1) then
2521         time00=MPI_Wtime()
2522 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2523 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2524 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2525 #ifdef MATGATHER
2526         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2527      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2528      &   FG_COMM1,IERR)
2529         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2530      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2531      &   FG_COMM1,IERR)
2532         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2533      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2534      &   FG_COMM1,IERR)
2535         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2536      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2537      &   FG_COMM1,IERR)
2538         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2539      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2540      &   FG_COMM1,IERR)
2541         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2542      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2543      &   FG_COMM1,IERR)
2544         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2545      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2546      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2547         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2548      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2549      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2550         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2551      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2552      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2553         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2554      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2555      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2556         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2557      &  then
2558         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2559      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2560      &   FG_COMM1,IERR)
2561         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2562      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2563      &   FG_COMM1,IERR)
2564         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2565      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2566      &   FG_COMM1,IERR)
2567        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2568      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2569      &   FG_COMM1,IERR)
2570         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2571      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2572      &   FG_COMM1,IERR)
2573         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2574      &   ivec_count(fg_rank1),
2575      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2576      &   FG_COMM1,IERR)
2577         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2578      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2579      &   FG_COMM1,IERR)
2580         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2581      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2582      &   FG_COMM1,IERR)
2583         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2584      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2585      &   FG_COMM1,IERR)
2586         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2587      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2588      &   FG_COMM1,IERR)
2589         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2590      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2591      &   FG_COMM1,IERR)
2592         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2593      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2594      &   FG_COMM1,IERR)
2595         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2596      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2597      &   FG_COMM1,IERR)
2598         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2599      &   ivec_count(fg_rank1),
2600      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2601      &   FG_COMM1,IERR)
2602         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2603      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2604      &   FG_COMM1,IERR)
2605        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2606      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2607      &   FG_COMM1,IERR)
2608         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2609      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2610      &   FG_COMM1,IERR)
2611        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2612      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2613      &   FG_COMM1,IERR)
2614         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2615      &   ivec_count(fg_rank1),
2616      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2617      &   FG_COMM1,IERR)
2618         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2619      &   ivec_count(fg_rank1),
2620      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2621      &   FG_COMM1,IERR)
2622         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2623      &   ivec_count(fg_rank1),
2624      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2625      &   MPI_MAT2,FG_COMM1,IERR)
2626         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2627      &   ivec_count(fg_rank1),
2628      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2629      &   MPI_MAT2,FG_COMM1,IERR)
2630         endif
2631 #else
2632 c Passes matrix info through the ring
2633       isend=fg_rank1
2634       irecv=fg_rank1-1
2635       if (irecv.lt.0) irecv=nfgtasks1-1
2636       iprev=irecv
2637       inext=fg_rank1+1
2638       if (inext.ge.nfgtasks1) inext=0
2639       do i=1,nfgtasks1-1
2640 c        write (iout,*) "isend",isend," irecv",irecv
2641 c        call flush(iout)
2642         lensend=lentyp(isend)
2643         lenrecv=lentyp(irecv)
2644 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2645 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2646 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2647 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2648 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2649 c        write (iout,*) "Gather ROTAT1"
2650 c        call flush(iout)
2651 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2652 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2653 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2654 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2655 c        write (iout,*) "Gather ROTAT2"
2656 c        call flush(iout)
2657         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2658      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2659      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2660      &   iprev,4400+irecv,FG_COMM,status,IERR)
2661 c        write (iout,*) "Gather ROTAT_OLD"
2662 c        call flush(iout)
2663         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2664      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2665      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2666      &   iprev,5500+irecv,FG_COMM,status,IERR)
2667 c        write (iout,*) "Gather PRECOMP11"
2668 c        call flush(iout)
2669         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2670      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2671      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2672      &   iprev,6600+irecv,FG_COMM,status,IERR)
2673 c        write (iout,*) "Gather PRECOMP12"
2674 c        call flush(iout)
2675         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2676      &  then
2677         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2678      &   MPI_ROTAT2(lensend),inext,7700+isend,
2679      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2680      &   iprev,7700+irecv,FG_COMM,status,IERR)
2681 c        write (iout,*) "Gather PRECOMP21"
2682 c        call flush(iout)
2683         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2684      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2685      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2686      &   iprev,8800+irecv,FG_COMM,status,IERR)
2687 c        write (iout,*) "Gather PRECOMP22"
2688 c        call flush(iout)
2689         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2690      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2691      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2692      &   MPI_PRECOMP23(lenrecv),
2693      &   iprev,9900+irecv,FG_COMM,status,IERR)
2694 c        write (iout,*) "Gather PRECOMP23"
2695 c        call flush(iout)
2696         endif
2697         isend=irecv
2698         irecv=irecv-1
2699         if (irecv.lt.0) irecv=nfgtasks1-1
2700       enddo
2701 #endif
2702         time_gather=time_gather+MPI_Wtime()-time00
2703       endif
2704 #ifdef DEBUG
2705 c      if (fg_rank.eq.0) then
2706         write (iout,*) "Arrays UG and UGDER"
2707         do i=1,nres-1
2708           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2709      &     ((ug(l,k,i),l=1,2),k=1,2),
2710      &     ((ugder(l,k,i),l=1,2),k=1,2)
2711         enddo
2712         write (iout,*) "Arrays UG2 and UG2DER"
2713         do i=1,nres-1
2714           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2715      &     ((ug2(l,k,i),l=1,2),k=1,2),
2716      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2717         enddo
2718         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2719         do i=1,nres-1
2720           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2721      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2722      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2723         enddo
2724         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2725         do i=1,nres-1
2726           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2727      &     costab(i),sintab(i),costab2(i),sintab2(i)
2728         enddo
2729         write (iout,*) "Array MUDER"
2730         do i=1,nres-1
2731           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2732         enddo
2733 c      endif
2734 #endif
2735 #endif
2736 cd      do i=1,nres
2737 cd        iti = itortyp(itype(i))
2738 cd        write (iout,*) i
2739 cd        do j=1,2
2740 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2741 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2742 cd        enddo
2743 cd      enddo
2744       return
2745       end
2746 C--------------------------------------------------------------------------
2747       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2748 C
2749 C This subroutine calculates the average interaction energy and its gradient
2750 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2751 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2752 C The potential depends both on the distance of peptide-group centers and on
2753 C the orientation of the CA-CA virtual bonds.
2754 C
2755       implicit real*8 (a-h,o-z)
2756 #ifdef MPI
2757       include 'mpif.h'
2758 #endif
2759       include 'DIMENSIONS'
2760       include 'COMMON.CONTROL'
2761       include 'COMMON.SETUP'
2762       include 'COMMON.IOUNITS'
2763       include 'COMMON.GEO'
2764       include 'COMMON.VAR'
2765       include 'COMMON.LOCAL'
2766       include 'COMMON.CHAIN'
2767       include 'COMMON.DERIV'
2768       include 'COMMON.INTERACT'
2769       include 'COMMON.CONTACTS'
2770       include 'COMMON.TORSION'
2771       include 'COMMON.VECTORS'
2772       include 'COMMON.FFIELD'
2773       include 'COMMON.TIME1'
2774       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2775      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2776       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2777      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2778       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2779      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2780      &    num_conti,j1,j2
2781 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2782 #ifdef MOMENT
2783       double precision scal_el /1.0d0/
2784 #else
2785       double precision scal_el /0.5d0/
2786 #endif
2787 C 12/13/98
2788 C 13-go grudnia roku pamietnego...
2789       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2790      &                   0.0d0,1.0d0,0.0d0,
2791      &                   0.0d0,0.0d0,1.0d0/
2792 cd      write(iout,*) 'In EELEC'
2793 cd      do i=1,nloctyp
2794 cd        write(iout,*) 'Type',i
2795 cd        write(iout,*) 'B1',B1(:,i)
2796 cd        write(iout,*) 'B2',B2(:,i)
2797 cd        write(iout,*) 'CC',CC(:,:,i)
2798 cd        write(iout,*) 'DD',DD(:,:,i)
2799 cd        write(iout,*) 'EE',EE(:,:,i)
2800 cd      enddo
2801 cd      call check_vecgrad
2802 cd      stop
2803       if (icheckgrad.eq.1) then
2804         do i=1,nres-1
2805           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2806           do k=1,3
2807             dc_norm(k,i)=dc(k,i)*fac
2808           enddo
2809 c          write (iout,*) 'i',i,' fac',fac
2810         enddo
2811       endif
2812       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2813      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2814      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2815 c        call vec_and_deriv
2816 #ifdef TIMING
2817         time01=MPI_Wtime()
2818 #endif
2819         call set_matrices
2820 #ifdef TIMING
2821         time_mat=time_mat+MPI_Wtime()-time01
2822 #endif
2823       endif
2824 cd      do i=1,nres-1
2825 cd        write (iout,*) 'i=',i
2826 cd        do k=1,3
2827 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2828 cd        enddo
2829 cd        do k=1,3
2830 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2831 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2832 cd        enddo
2833 cd      enddo
2834       t_eelecij=0.0d0
2835       ees=0.0D0
2836       evdw1=0.0D0
2837       eel_loc=0.0d0
2838       eello_turn3=0.0d0
2839       eello_turn4=0.0d0
2840       ind=0
2841       do i=1,nres
2842         num_cont_hb(i)=0
2843       enddo
2844 cd      print '(a)','Enter EELEC'
2845 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2846       do i=1,nres
2847         gel_loc_loc(i)=0.0d0
2848         gcorr_loc(i)=0.0d0
2849       enddo
2850 c
2851 c
2852 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2853 C
2854 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2855 C
2856       do i=iturn3_start,iturn3_end
2857         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2858      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2859         dxi=dc(1,i)
2860         dyi=dc(2,i)
2861         dzi=dc(3,i)
2862         dx_normi=dc_norm(1,i)
2863         dy_normi=dc_norm(2,i)
2864         dz_normi=dc_norm(3,i)
2865         xmedi=c(1,i)+0.5d0*dxi
2866         ymedi=c(2,i)+0.5d0*dyi
2867         zmedi=c(3,i)+0.5d0*dzi
2868         num_conti=0
2869 c TU ZLE
2870 c        call eelecij(i,i+2,ees,evdw1,eel_loc)
2871         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2872         num_cont_hb(i)=num_conti
2873       enddo
2874       do i=iturn4_start,iturn4_end
2875         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2876      &    .or. itype(i+3).eq.ntyp1
2877      &    .or. itype(i+4).eq.ntyp1) cycle
2878         dxi=dc(1,i)
2879         dyi=dc(2,i)
2880         dzi=dc(3,i)
2881         dx_normi=dc_norm(1,i)
2882         dy_normi=dc_norm(2,i)
2883         dz_normi=dc_norm(3,i)
2884         xmedi=c(1,i)+0.5d0*dxi
2885         ymedi=c(2,i)+0.5d0*dyi
2886         zmedi=c(3,i)+0.5d0*dzi
2887         num_conti=num_cont_hb(i)
2888 c TU ZLE
2889 c        call eelecij(i,i+3,ees,evdw1,eel_loc)
2890         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2891      &   call eturn4(i,eello_turn4)
2892         num_cont_hb(i)=num_conti
2893       enddo   ! i
2894 c
2895 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2896 c
2897 c      do i=iatel_s,iatel_e
2898        do i=4,5
2899         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2900         dxi=dc(1,i)
2901         dyi=dc(2,i)
2902         dzi=dc(3,i)
2903         dx_normi=dc_norm(1,i)
2904         dy_normi=dc_norm(2,i)
2905         dz_normi=dc_norm(3,i)
2906         xmedi=c(1,i)+0.5d0*dxi
2907         ymedi=c(2,i)+0.5d0*dyi
2908         zmedi=c(3,i)+0.5d0*dzi
2909 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2910         num_conti=num_cont_hb(i)
2911 c        do j=ielstart(i),ielend(i)
2912          do j=8,9
2913           write (iout,*) 'tu wchodze',i,j,itype(i),itype(j)
2914           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2915           call eelecij(i,j,ees,evdw1,eel_loc)
2916         enddo ! j
2917         num_cont_hb(i)=num_conti
2918       enddo   ! i
2919 c      write (iout,*) "Number of loop steps in EELEC:",ind
2920 cd      do i=1,nres
2921 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2922 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2923 cd      enddo
2924 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2925 ccc      eel_loc=eel_loc+eello_turn3
2926 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2927       return
2928       end
2929 C-------------------------------------------------------------------------------
2930       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2931       implicit real*8 (a-h,o-z)
2932       include 'DIMENSIONS'
2933 #ifdef MPI
2934       include "mpif.h"
2935 #endif
2936       include 'COMMON.CONTROL'
2937       include 'COMMON.IOUNITS'
2938       include 'COMMON.GEO'
2939       include 'COMMON.VAR'
2940       include 'COMMON.LOCAL'
2941       include 'COMMON.CHAIN'
2942       include 'COMMON.DERIV'
2943       include 'COMMON.INTERACT'
2944       include 'COMMON.CONTACTS'
2945       include 'COMMON.TORSION'
2946       include 'COMMON.VECTORS'
2947       include 'COMMON.FFIELD'
2948       include 'COMMON.TIME1'
2949       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2950      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2951       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2952      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2953      &    gmuij2(4),gmuji2(4)
2954       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2955      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2956      &    num_conti,j1,j2
2957 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2958 #ifdef MOMENT
2959       double precision scal_el /1.0d0/
2960 #else
2961       double precision scal_el /0.5d0/
2962 #endif
2963 C 12/13/98
2964 C 13-go grudnia roku pamietnego...
2965       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2966      &                   0.0d0,1.0d0,0.0d0,
2967      &                   0.0d0,0.0d0,1.0d0/
2968 c          time00=MPI_Wtime()
2969 cd      write (iout,*) "eelecij",i,j
2970 c          ind=ind+1
2971           iteli=itel(i)
2972           itelj=itel(j)
2973           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2974           aaa=app(iteli,itelj)
2975           bbb=bpp(iteli,itelj)
2976           ael6i=ael6(iteli,itelj)
2977           ael3i=ael3(iteli,itelj)
2978           dxj=dc(1,j)
2979           dyj=dc(2,j)
2980           dzj=dc(3,j)
2981           dx_normj=dc_norm(1,j)
2982           dy_normj=dc_norm(2,j)
2983           dz_normj=dc_norm(3,j)
2984           xj=c(1,j)+0.5D0*dxj-xmedi
2985           yj=c(2,j)+0.5D0*dyj-ymedi
2986           zj=c(3,j)+0.5D0*dzj-zmedi
2987           rij=xj*xj+yj*yj+zj*zj
2988           rrmij=1.0D0/rij
2989           rij=dsqrt(rij)
2990           rmij=1.0D0/rij
2991           r3ij=rrmij*rmij
2992           r6ij=r3ij*r3ij
2993           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2994           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2995           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2996           fac=cosa-3.0D0*cosb*cosg
2997           ev1=aaa*r6ij*r6ij
2998 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2999           if (j.eq.i+2) ev1=scal_el*ev1
3000           ev2=bbb*r6ij
3001           fac3=ael6i*r6ij
3002           fac4=ael3i*r3ij
3003           evdwij=ev1+ev2
3004           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3005           el2=fac4*fac
3006           eesij=el1+el2
3007 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3008           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3009           ees=ees+eesij
3010           evdw1=evdw1+evdwij
3011 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3012 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3013 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3014 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3015
3016           if (energy_dec) then
3017               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3018      &'evdw1',i,j,evdwij
3019      &,iteli,itelj,aaa,evdw1
3020               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3021           endif
3022
3023 C
3024 C Calculate contributions to the Cartesian gradient.
3025 C
3026 #ifdef SPLITELE
3027           facvdw=-6*rrmij*(ev1+evdwij)
3028           facel=-3*rrmij*(el1+eesij)
3029           fac1=fac
3030           erij(1)=xj*rmij
3031           erij(2)=yj*rmij
3032           erij(3)=zj*rmij
3033 *
3034 * Radial derivatives. First process both termini of the fragment (i,j)
3035 *
3036           ggg(1)=facel*xj
3037           ggg(2)=facel*yj
3038           ggg(3)=facel*zj
3039 c          do k=1,3
3040 c            ghalf=0.5D0*ggg(k)
3041 c            gelc(k,i)=gelc(k,i)+ghalf
3042 c            gelc(k,j)=gelc(k,j)+ghalf
3043 c          enddo
3044 c 9/28/08 AL Gradient compotents will be summed only at the end
3045           do k=1,3
3046             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3047             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3048           enddo
3049 *
3050 * Loop over residues i+1 thru j-1.
3051 *
3052 cgrad          do k=i+1,j-1
3053 cgrad            do l=1,3
3054 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3055 cgrad            enddo
3056 cgrad          enddo
3057           ggg(1)=facvdw*xj
3058           ggg(2)=facvdw*yj
3059           ggg(3)=facvdw*zj
3060 c          do k=1,3
3061 c            ghalf=0.5D0*ggg(k)
3062 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3063 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3064 c          enddo
3065 c 9/28/08 AL Gradient compotents will be summed only at the end
3066           do k=1,3
3067             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3068             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3069           enddo
3070 *
3071 * Loop over residues i+1 thru j-1.
3072 *
3073 cgrad          do k=i+1,j-1
3074 cgrad            do l=1,3
3075 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3076 cgrad            enddo
3077 cgrad          enddo
3078 #else
3079           facvdw=ev1+evdwij
3080           facel=el1+eesij
3081           fac1=fac
3082           fac=-3*rrmij*(facvdw+facvdw+facel)
3083           erij(1)=xj*rmij
3084           erij(2)=yj*rmij
3085           erij(3)=zj*rmij
3086 *
3087 * Radial derivatives. First process both termini of the fragment (i,j)
3088 *
3089           ggg(1)=fac*xj
3090           ggg(2)=fac*yj
3091           ggg(3)=fac*zj
3092 c          do k=1,3
3093 c            ghalf=0.5D0*ggg(k)
3094 c            gelc(k,i)=gelc(k,i)+ghalf
3095 c            gelc(k,j)=gelc(k,j)+ghalf
3096 c          enddo
3097 c 9/28/08 AL Gradient compotents will be summed only at the end
3098           do k=1,3
3099             gelc_long(k,j)=gelc(k,j)+ggg(k)
3100             gelc_long(k,i)=gelc(k,i)-ggg(k)
3101           enddo
3102 *
3103 * Loop over residues i+1 thru j-1.
3104 *
3105 cgrad          do k=i+1,j-1
3106 cgrad            do l=1,3
3107 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3108 cgrad            enddo
3109 cgrad          enddo
3110 c 9/28/08 AL Gradient compotents will be summed only at the end
3111           ggg(1)=facvdw*xj
3112           ggg(2)=facvdw*yj
3113           ggg(3)=facvdw*zj
3114           do k=1,3
3115             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3116             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3117           enddo
3118 #endif
3119 *
3120 * Angular part
3121 *
3122           ecosa=2.0D0*fac3*fac1+fac4
3123           fac4=-3.0D0*fac4
3124           fac3=-6.0D0*fac3
3125           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3126           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3127           do k=1,3
3128             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3129             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3130           enddo
3131 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3132 cd   &          (dcosg(k),k=1,3)
3133           do k=1,3
3134             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3135           enddo
3136 c          do k=1,3
3137 c            ghalf=0.5D0*ggg(k)
3138 c            gelc(k,i)=gelc(k,i)+ghalf
3139 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3140 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3141 c            gelc(k,j)=gelc(k,j)+ghalf
3142 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3143 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3144 c          enddo
3145 cgrad          do k=i+1,j-1
3146 cgrad            do l=1,3
3147 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3148 cgrad            enddo
3149 cgrad          enddo
3150           do k=1,3
3151             gelc(k,i)=gelc(k,i)
3152      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3153      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3154             gelc(k,j)=gelc(k,j)
3155      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3156      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3157             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3158             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3159           enddo
3160           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3161      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3162      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3163 C
3164 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3165 C   energy of a peptide unit is assumed in the form of a second-order
3166 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3167 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3168 C   are computed for EVERY pair of non-contiguous peptide groups.
3169 C
3170
3171           if (j.lt.nres-1) then
3172             j1=j+1
3173             j2=j-1
3174           else
3175             j1=j-1
3176             j2=j-2
3177           endif
3178           kkk=0
3179           lll=0
3180           do k=1,2
3181             do l=1,2
3182               kkk=kkk+1
3183               muij(kkk)=mu(k,i)*mu(l,j)
3184 #ifdef NEWCORR
3185              gmuij1(kkk)=gtb1(k,i)*mu(l,j)
3186              write(iout,*) 'kkk=', gtb1(k,i)*mu(l,j),gtb1(k,i),k,i
3187              gmuij2(kkk)=gUb2(k,i-1)*mu(l,j)
3188              gmuji1(kkk)=mu(k,i)*gtb1(l,j)
3189              write(iout,*) 'kkk=', gtb1(k,i)*mu(l,j),gtb1(l,j),l,j
3190              gmuji2(kkk)=mu(k,i)*gUb2(l,j-1)
3191 #endif
3192             enddo
3193           enddo
3194 cd         write (iout,*) 'EELEC: i',i,' j',j
3195 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3196 cd          write(iout,*) 'muij',muij
3197           ury=scalar(uy(1,i),erij)
3198           urz=scalar(uz(1,i),erij)
3199           vry=scalar(uy(1,j),erij)
3200           vrz=scalar(uz(1,j),erij)
3201           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3202           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3203           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3204           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3205           fac=dsqrt(-ael6i)*r3ij
3206           a22=a22*fac
3207           a23=a23*fac
3208           a32=a32*fac
3209           a33=a33*fac
3210 cd          write (iout,'(4i5,4f10.5)')
3211 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3212 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3213 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3214 cd     &      uy(:,j),uz(:,j)
3215 cd          write (iout,'(4f10.5)')
3216 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3217 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3218 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3219 cd           write (iout,'(9f10.5/)')
3220 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3221 C Derivatives of the elements of A in virtual-bond vectors
3222           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3223           do k=1,3
3224             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3225             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3226             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3227             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3228             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3229             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3230             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3231             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3232             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3233             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3234             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3235             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3236           enddo
3237 C Compute radial contributions to the gradient
3238           facr=-3.0d0*rrmij
3239           a22der=a22*facr
3240           a23der=a23*facr
3241           a32der=a32*facr
3242           a33der=a33*facr
3243           agg(1,1)=a22der*xj
3244           agg(2,1)=a22der*yj
3245           agg(3,1)=a22der*zj
3246           agg(1,2)=a23der*xj
3247           agg(2,2)=a23der*yj
3248           agg(3,2)=a23der*zj
3249           agg(1,3)=a32der*xj
3250           agg(2,3)=a32der*yj
3251           agg(3,3)=a32der*zj
3252           agg(1,4)=a33der*xj
3253           agg(2,4)=a33der*yj
3254           agg(3,4)=a33der*zj
3255 C Add the contributions coming from er
3256           fac3=-3.0d0*fac
3257           do k=1,3
3258             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3259             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3260             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3261             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3262           enddo
3263           do k=1,3
3264 C Derivatives in DC(i)
3265 cgrad            ghalf1=0.5d0*agg(k,1)
3266 cgrad            ghalf2=0.5d0*agg(k,2)
3267 cgrad            ghalf3=0.5d0*agg(k,3)
3268 cgrad            ghalf4=0.5d0*agg(k,4)
3269             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3270      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3271             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3272      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3273             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3274      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3275             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3276      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3277 C Derivatives in DC(i+1)
3278             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3279      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3280             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3281      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3282             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3283      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3284             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3285      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3286 C Derivatives in DC(j)
3287             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3288      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3289             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3290      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3291             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3292      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3293             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3294      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3295 C Derivatives in DC(j+1) or DC(nres-1)
3296             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3297      &      -3.0d0*vryg(k,3)*ury)
3298             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3299      &      -3.0d0*vrzg(k,3)*ury)
3300             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3301      &      -3.0d0*vryg(k,3)*urz)
3302             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3303      &      -3.0d0*vrzg(k,3)*urz)
3304 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3305 cgrad              do l=1,4
3306 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3307 cgrad              enddo
3308 cgrad            endif
3309           enddo
3310           acipa(1,1)=a22
3311           acipa(1,2)=a23
3312           acipa(2,1)=a32
3313           acipa(2,2)=a33
3314           a22=-a22
3315           a23=-a23
3316           do l=1,2
3317             do k=1,3
3318               agg(k,l)=-agg(k,l)
3319               aggi(k,l)=-aggi(k,l)
3320               aggi1(k,l)=-aggi1(k,l)
3321               aggj(k,l)=-aggj(k,l)
3322               aggj1(k,l)=-aggj1(k,l)
3323             enddo
3324           enddo
3325           if (j.lt.nres-1) then
3326             a22=-a22
3327             a32=-a32
3328             do l=1,3,2
3329               do k=1,3
3330                 agg(k,l)=-agg(k,l)
3331                 aggi(k,l)=-aggi(k,l)
3332                 aggi1(k,l)=-aggi1(k,l)
3333                 aggj(k,l)=-aggj(k,l)
3334                 aggj1(k,l)=-aggj1(k,l)
3335               enddo
3336             enddo
3337           else
3338             a22=-a22
3339             a23=-a23
3340             a32=-a32
3341             a33=-a33
3342             do l=1,4
3343               do k=1,3
3344                 agg(k,l)=-agg(k,l)
3345                 aggi(k,l)=-aggi(k,l)
3346                 aggi1(k,l)=-aggi1(k,l)
3347                 aggj(k,l)=-aggj(k,l)
3348                 aggj1(k,l)=-aggj1(k,l)
3349               enddo
3350             enddo
3351           endif
3352           ENDIF ! WCORR
3353           IF (wel_loc.gt.0.0d0) THEN
3354 C Contribution to the local-electrostatic energy coming from the i-j pair
3355           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3356      &     +a33*muij(4)
3357 C Calculate patrial derivative for theta angle
3358 #ifdef NEWCORR
3359          geel_loc_ij=a22*gmuij1(1)
3360      &     +a23*gmuij1(2)
3361      &     +a32*gmuij1(3)
3362      &     +a33*gmuij1(4)
3363          write(iout,*) "derivative over thatai"
3364          write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3365      &   a33*gmuij1(4)
3366          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3367      &      geel_loc_ij*wel_loc
3368          write(iout,*) "derivative over thatai-1"
3369          write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3370      &   a33*gmuij2(4)
3371          geel_loc_ij=a22*gmuij2(1)+a23*gmuij2(2)+a32*gmuij2(3)
3372      &     +a33*gmuij2(4)
3373          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3374      &      geel_loc_ij*wel_loc
3375          geel_loc_ji=a22*gmuji1(1)+a23*gmuji1(2)+a32*gmuji1(3)
3376      &     +a33*gmuji1(4)
3377          write(iout,*) "derivative over thataj"
3378          write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3379      &   a33*gmuji1(4)
3380
3381          gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3382      &      geel_loc_ji*wel_loc
3383          geel_loc_ji=a22*gmuji2(1)+a23*gmuji2(2)+a32*gmuji2(3)
3384      &     +a33*gmuji2(4)
3385          write(iout,*) "derivative over thataj-1"
3386          write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3387      &   a33*gmuji2(4)
3388          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3389      &      geel_loc_ji*wel_loc
3390 #endif
3391 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3392
3393           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3394      &            'eelloc',i,j,eel_loc_ij
3395 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3396
3397           eel_loc=eel_loc+eel_loc_ij
3398 C Partial derivatives in virtual-bond dihedral angles gamma
3399           if (i.gt.1)
3400      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3401      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3402      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3403           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3404      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3405      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3406 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3407           do l=1,3
3408             ggg(l)=agg(l,1)*muij(1)+
3409      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3410             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3411             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3412 cgrad            ghalf=0.5d0*ggg(l)
3413 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3414 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3415           enddo
3416 cgrad          do k=i+1,j2
3417 cgrad            do l=1,3
3418 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3419 cgrad            enddo
3420 cgrad          enddo
3421 C Remaining derivatives of eello
3422           do l=1,3
3423             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3424      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3425             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3426      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3427             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3428      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3429             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3430      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3431           enddo
3432           ENDIF
3433 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3434 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3435           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3436      &       .and. num_conti.le.maxconts) then
3437 c            write (iout,*) i,j," entered corr"
3438 C
3439 C Calculate the contact function. The ith column of the array JCONT will
3440 C contain the numbers of atoms that make contacts with the atom I (of numbers
3441 C greater than I). The arrays FACONT and GACONT will contain the values of
3442 C the contact function and its derivative.
3443 c           r0ij=1.02D0*rpp(iteli,itelj)
3444 c           r0ij=1.11D0*rpp(iteli,itelj)
3445             r0ij=2.20D0*rpp(iteli,itelj)
3446 c           r0ij=1.55D0*rpp(iteli,itelj)
3447             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3448             if (fcont.gt.0.0D0) then
3449               num_conti=num_conti+1
3450               if (num_conti.gt.maxconts) then
3451                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3452      &                         ' will skip next contacts for this conf.'
3453               else
3454                 jcont_hb(num_conti,i)=j
3455 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3456 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3457                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3458      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3459 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3460 C  terms.
3461                 d_cont(num_conti,i)=rij
3462 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3463 C     --- Electrostatic-interaction matrix ---
3464                 a_chuj(1,1,num_conti,i)=a22
3465                 a_chuj(1,2,num_conti,i)=a23
3466                 a_chuj(2,1,num_conti,i)=a32
3467                 a_chuj(2,2,num_conti,i)=a33
3468 C     --- Gradient of rij
3469                 do kkk=1,3
3470                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3471                 enddo
3472                 kkll=0
3473                 do k=1,2
3474                   do l=1,2
3475                     kkll=kkll+1
3476                     do m=1,3
3477                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3478                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3479                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3480                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3481                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3482                     enddo
3483                   enddo
3484                 enddo
3485                 ENDIF
3486                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3487 C Calculate contact energies
3488                 cosa4=4.0D0*cosa
3489                 wij=cosa-3.0D0*cosb*cosg
3490                 cosbg1=cosb+cosg
3491                 cosbg2=cosb-cosg
3492 c               fac3=dsqrt(-ael6i)/r0ij**3
3493                 fac3=dsqrt(-ael6i)*r3ij
3494 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3495                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3496                 if (ees0tmp.gt.0) then
3497                   ees0pij=dsqrt(ees0tmp)
3498                 else
3499                   ees0pij=0
3500                 endif
3501 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3502                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3503                 if (ees0tmp.gt.0) then
3504                   ees0mij=dsqrt(ees0tmp)
3505                 else
3506                   ees0mij=0
3507                 endif
3508 c               ees0mij=0.0D0
3509                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3510                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3511 C Diagnostics. Comment out or remove after debugging!
3512 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3513 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3514 c               ees0m(num_conti,i)=0.0D0
3515 C End diagnostics.
3516 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3517 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3518 C Angular derivatives of the contact function
3519                 ees0pij1=fac3/ees0pij
3520                 ees0mij1=fac3/ees0mij
3521                 fac3p=-3.0D0*fac3*rrmij
3522                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3523                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3524 c               ees0mij1=0.0D0
3525                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3526                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3527                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3528                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3529                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3530                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3531                 ecosap=ecosa1+ecosa2
3532                 ecosbp=ecosb1+ecosb2
3533                 ecosgp=ecosg1+ecosg2
3534                 ecosam=ecosa1-ecosa2
3535                 ecosbm=ecosb1-ecosb2
3536                 ecosgm=ecosg1-ecosg2
3537 C Diagnostics
3538 c               ecosap=ecosa1
3539 c               ecosbp=ecosb1
3540 c               ecosgp=ecosg1
3541 c               ecosam=0.0D0
3542 c               ecosbm=0.0D0
3543 c               ecosgm=0.0D0
3544 C End diagnostics
3545                 facont_hb(num_conti,i)=fcont
3546                 fprimcont=fprimcont/rij
3547 cd              facont_hb(num_conti,i)=1.0D0
3548 C Following line is for diagnostics.
3549 cd              fprimcont=0.0D0
3550                 do k=1,3
3551                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3552                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3553                 enddo
3554                 do k=1,3
3555                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3556                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3557                 enddo
3558                 gggp(1)=gggp(1)+ees0pijp*xj
3559                 gggp(2)=gggp(2)+ees0pijp*yj
3560                 gggp(3)=gggp(3)+ees0pijp*zj
3561                 gggm(1)=gggm(1)+ees0mijp*xj
3562                 gggm(2)=gggm(2)+ees0mijp*yj
3563                 gggm(3)=gggm(3)+ees0mijp*zj
3564 C Derivatives due to the contact function
3565                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3566                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3567                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3568                 do k=1,3
3569 c
3570 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3571 c          following the change of gradient-summation algorithm.
3572 c
3573 cgrad                  ghalfp=0.5D0*gggp(k)
3574 cgrad                  ghalfm=0.5D0*gggm(k)
3575                   gacontp_hb1(k,num_conti,i)=!ghalfp
3576      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3577      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3578                   gacontp_hb2(k,num_conti,i)=!ghalfp
3579      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3580      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3581                   gacontp_hb3(k,num_conti,i)=gggp(k)
3582                   gacontm_hb1(k,num_conti,i)=!ghalfm
3583      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3584      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3585                   gacontm_hb2(k,num_conti,i)=!ghalfm
3586      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3587      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3588                   gacontm_hb3(k,num_conti,i)=gggm(k)
3589                 enddo
3590 C Diagnostics. Comment out or remove after debugging!
3591 cdiag           do k=1,3
3592 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3593 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3594 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3595 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3596 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3597 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3598 cdiag           enddo
3599               ENDIF ! wcorr
3600               endif  ! num_conti.le.maxconts
3601             endif  ! fcont.gt.0
3602           endif    ! j.gt.i+1
3603           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3604             do k=1,4
3605               do l=1,3
3606                 ghalf=0.5d0*agg(l,k)
3607                 aggi(l,k)=aggi(l,k)+ghalf
3608                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3609                 aggj(l,k)=aggj(l,k)+ghalf
3610               enddo
3611             enddo
3612             if (j.eq.nres-1 .and. i.lt.j-2) then
3613               do k=1,4
3614                 do l=1,3
3615                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3616                 enddo
3617               enddo
3618             endif
3619           endif
3620 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3621       return
3622       end
3623 C-----------------------------------------------------------------------------
3624       subroutine eturn3(i,eello_turn3)
3625 C Third- and fourth-order contributions from turns
3626       implicit real*8 (a-h,o-z)
3627       include 'DIMENSIONS'
3628       include 'COMMON.IOUNITS'
3629       include 'COMMON.GEO'
3630       include 'COMMON.VAR'
3631       include 'COMMON.LOCAL'
3632       include 'COMMON.CHAIN'
3633       include 'COMMON.DERIV'
3634       include 'COMMON.INTERACT'
3635       include 'COMMON.CONTACTS'
3636       include 'COMMON.TORSION'
3637       include 'COMMON.VECTORS'
3638       include 'COMMON.FFIELD'
3639       include 'COMMON.CONTROL'
3640       dimension ggg(3)
3641       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3642      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3643      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3644       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3645      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3646       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3647      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3648      &    num_conti,j1,j2
3649       j=i+2
3650 c      write (iout,*) "eturn3",i,j,j1,j2
3651       a_temp(1,1)=a22
3652       a_temp(1,2)=a23
3653       a_temp(2,1)=a32
3654       a_temp(2,2)=a33
3655 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3656 C
3657 C               Third-order contributions
3658 C
3659 C                 (i+2)o----(i+3)
3660 C                      | |
3661 C                      | |
3662 C                 (i+1)o----i
3663 C
3664 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3665 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3666         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3667         call transpose2(auxmat(1,1),auxmat1(1,1))
3668         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3669         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3670         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3671      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3672 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3673 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3674 cd     &    ' eello_turn3_num',4*eello_turn3_num
3675 C Derivatives in gamma(i)
3676         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3677         call transpose2(auxmat2(1,1),auxmat3(1,1))
3678         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3679         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3680 C Derivatives in gamma(i+1)
3681         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3682         call transpose2(auxmat2(1,1),auxmat3(1,1))
3683         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3684         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3685      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3686 C Cartesian derivatives
3687         do l=1,3
3688 c            ghalf1=0.5d0*agg(l,1)
3689 c            ghalf2=0.5d0*agg(l,2)
3690 c            ghalf3=0.5d0*agg(l,3)
3691 c            ghalf4=0.5d0*agg(l,4)
3692           a_temp(1,1)=aggi(l,1)!+ghalf1
3693           a_temp(1,2)=aggi(l,2)!+ghalf2
3694           a_temp(2,1)=aggi(l,3)!+ghalf3
3695           a_temp(2,2)=aggi(l,4)!+ghalf4
3696           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3697           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3698      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3699           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3700           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3701           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3702           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3703           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3704           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3705      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3706           a_temp(1,1)=aggj(l,1)!+ghalf1
3707           a_temp(1,2)=aggj(l,2)!+ghalf2
3708           a_temp(2,1)=aggj(l,3)!+ghalf3
3709           a_temp(2,2)=aggj(l,4)!+ghalf4
3710           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3711           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3712      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3713           a_temp(1,1)=aggj1(l,1)
3714           a_temp(1,2)=aggj1(l,2)
3715           a_temp(2,1)=aggj1(l,3)
3716           a_temp(2,2)=aggj1(l,4)
3717           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3718           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3719      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3720         enddo
3721       return
3722       end
3723 C-------------------------------------------------------------------------------
3724       subroutine eturn4(i,eello_turn4)
3725 C Third- and fourth-order contributions from turns
3726       implicit real*8 (a-h,o-z)
3727       include 'DIMENSIONS'
3728       include 'COMMON.IOUNITS'
3729       include 'COMMON.GEO'
3730       include 'COMMON.VAR'
3731       include 'COMMON.LOCAL'
3732       include 'COMMON.CHAIN'
3733       include 'COMMON.DERIV'
3734       include 'COMMON.INTERACT'
3735       include 'COMMON.CONTACTS'
3736       include 'COMMON.TORSION'
3737       include 'COMMON.VECTORS'
3738       include 'COMMON.FFIELD'
3739       include 'COMMON.CONTROL'
3740       dimension ggg(3)
3741       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3742      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3743      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2)
3744       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3745      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3746       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3747      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3748      &    num_conti,j1,j2
3749       j=i+3
3750 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3751 C
3752 C               Fourth-order contributions
3753 C
3754 C                 (i+3)o----(i+4)
3755 C                     /  |
3756 C               (i+2)o   |
3757 C                     \  |
3758 C                 (i+1)o----i
3759 C
3760 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3761 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3762 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3763         a_temp(1,1)=a22
3764         a_temp(1,2)=a23
3765         a_temp(2,1)=a32
3766         a_temp(2,2)=a33
3767         iti1=itortyp(itype(i+1))
3768         iti2=itortyp(itype(i+2))
3769         iti3=itortyp(itype(i+3))
3770 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3771         call transpose2(EUg(1,1,i+1),e1t(1,1))
3772         call transpose2(Eug(1,1,i+2),e2t(1,1))
3773         call transpose2(Eug(1,1,i+3),e3t(1,1))
3774         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3775         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3776         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3777 c        s1=0.0
3778 c        gs1=0.0
3779         s1=scalar2(b1(1,i+2),auxvec(1))
3780 c        gs1=scalar2(gtb1(1,i+2),auxgvec(1))
3781         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3782         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3783         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3784 c        s2=0.0
3785 c        gs2=0.0
3786         s2=scalar2(b1(1,i+1),auxvec(1))
3787 c        gs2=scalar2(gtb1(1,i+1),auxgvec(1))
3788 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),ggb1(1,i+2),
3789 c     &  ggb1(1,i+1)
3790         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3791         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3792         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3793         eello_turn4=eello_turn4-(s1+s2+s3)
3794 #ifdef NEWCORR
3795 c        geel_loc_ij=-(gs1+gs2)
3796 c         gloc(nphi+i,icg)=gloc(nphi+i,icg)-
3797 c     &   gs1
3798 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3799 c     &   gs2
3800 #endif
3801         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3802      &      'eturn4',i,j,-(s1+s2+s3)
3803 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3804 cd     &    ' eello_turn4_num',8*eello_turn4_num
3805 C Derivatives in gamma(i)
3806         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3807         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3808         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3809         s1=scalar2(b1(1,i+2),auxvec(1))
3810         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3811         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3812         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3813 C Derivatives in gamma(i+1)
3814         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3815         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3816         s2=scalar2(b1(1,i+1),auxvec(1))
3817         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3818         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3819         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3820         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3821 C Derivatives in gamma(i+2)
3822         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3823         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3824         s1=scalar2(b1(1,i+2),auxvec(1))
3825         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3826         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3827         s2=scalar2(b1(1,i+1),auxvec(1))
3828         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3829         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3830         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3831         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3832 C Cartesian derivatives
3833 C Derivatives of this turn contributions in DC(i+2)
3834         if (j.lt.nres-1) then
3835           do l=1,3
3836             a_temp(1,1)=agg(l,1)
3837             a_temp(1,2)=agg(l,2)
3838             a_temp(2,1)=agg(l,3)
3839             a_temp(2,2)=agg(l,4)
3840             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3841             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3842             s1=scalar2(b1(1,i+2),auxvec(1))
3843             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3844             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3845             s2=scalar2(b1(1,i+1),auxvec(1))
3846             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3847             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3848             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3849             ggg(l)=-(s1+s2+s3)
3850             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3851           enddo
3852         endif
3853 C Remaining derivatives of this turn contribution
3854         do l=1,3
3855           a_temp(1,1)=aggi(l,1)
3856           a_temp(1,2)=aggi(l,2)
3857           a_temp(2,1)=aggi(l,3)
3858           a_temp(2,2)=aggi(l,4)
3859           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3860           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3861           s1=scalar2(b1(1,i+2),auxvec(1))
3862           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3863           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3864           s2=scalar2(b1(1,i+1),auxvec(1))
3865           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3866           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3867           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3868           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3869           a_temp(1,1)=aggi1(l,1)
3870           a_temp(1,2)=aggi1(l,2)
3871           a_temp(2,1)=aggi1(l,3)
3872           a_temp(2,2)=aggi1(l,4)
3873           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3874           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3875           s1=scalar2(b1(1,i+2),auxvec(1))
3876           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3877           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3878           s2=scalar2(b1(1,i+1),auxvec(1))
3879           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3880           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3881           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3882           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3883           a_temp(1,1)=aggj(l,1)
3884           a_temp(1,2)=aggj(l,2)
3885           a_temp(2,1)=aggj(l,3)
3886           a_temp(2,2)=aggj(l,4)
3887           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3888           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3889           s1=scalar2(b1(1,i+2),auxvec(1))
3890           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3891           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3892           s2=scalar2(b1(1,i+1),auxvec(1))
3893           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3894           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3895           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3896           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3897           a_temp(1,1)=aggj1(l,1)
3898           a_temp(1,2)=aggj1(l,2)
3899           a_temp(2,1)=aggj1(l,3)
3900           a_temp(2,2)=aggj1(l,4)
3901           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3902           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3903           s1=scalar2(b1(1,i+2),auxvec(1))
3904           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3905           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3906           s2=scalar2(b1(1,i+1),auxvec(1))
3907           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3908           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3909           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3910 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3911           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3912         enddo
3913       return
3914       end
3915 C-----------------------------------------------------------------------------
3916       subroutine vecpr(u,v,w)
3917       implicit real*8(a-h,o-z)
3918       dimension u(3),v(3),w(3)
3919       w(1)=u(2)*v(3)-u(3)*v(2)
3920       w(2)=-u(1)*v(3)+u(3)*v(1)
3921       w(3)=u(1)*v(2)-u(2)*v(1)
3922       return
3923       end
3924 C-----------------------------------------------------------------------------
3925       subroutine unormderiv(u,ugrad,unorm,ungrad)
3926 C This subroutine computes the derivatives of a normalized vector u, given
3927 C the derivatives computed without normalization conditions, ugrad. Returns
3928 C ungrad.
3929       implicit none
3930       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3931       double precision vec(3)
3932       double precision scalar
3933       integer i,j
3934 c      write (2,*) 'ugrad',ugrad
3935 c      write (2,*) 'u',u
3936       do i=1,3
3937         vec(i)=scalar(ugrad(1,i),u(1))
3938       enddo
3939 c      write (2,*) 'vec',vec
3940       do i=1,3
3941         do j=1,3
3942           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3943         enddo
3944       enddo
3945 c      write (2,*) 'ungrad',ungrad
3946       return
3947       end
3948 C-----------------------------------------------------------------------------
3949       subroutine escp_soft_sphere(evdw2,evdw2_14)
3950 C
3951 C This subroutine calculates the excluded-volume interaction energy between
3952 C peptide-group centers and side chains and its gradient in virtual-bond and
3953 C side-chain vectors.
3954 C
3955       implicit real*8 (a-h,o-z)
3956       include 'DIMENSIONS'
3957       include 'COMMON.GEO'
3958       include 'COMMON.VAR'
3959       include 'COMMON.LOCAL'
3960       include 'COMMON.CHAIN'
3961       include 'COMMON.DERIV'
3962       include 'COMMON.INTERACT'
3963       include 'COMMON.FFIELD'
3964       include 'COMMON.IOUNITS'
3965       include 'COMMON.CONTROL'
3966       dimension ggg(3)
3967       evdw2=0.0D0
3968       evdw2_14=0.0d0
3969       r0_scp=4.5d0
3970 cd    print '(a)','Enter ESCP'
3971 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3972       do i=iatscp_s,iatscp_e
3973         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3974         iteli=itel(i)
3975         xi=0.5D0*(c(1,i)+c(1,i+1))
3976         yi=0.5D0*(c(2,i)+c(2,i+1))
3977         zi=0.5D0*(c(3,i)+c(3,i+1))
3978
3979         do iint=1,nscp_gr(i)
3980
3981         do j=iscpstart(i,iint),iscpend(i,iint)
3982           if (itype(j).eq.ntyp1) cycle
3983           itypj=iabs(itype(j))
3984 C Uncomment following three lines for SC-p interactions
3985 c         xj=c(1,nres+j)-xi
3986 c         yj=c(2,nres+j)-yi
3987 c         zj=c(3,nres+j)-zi
3988 C Uncomment following three lines for Ca-p interactions
3989           xj=c(1,j)-xi
3990           yj=c(2,j)-yi
3991           zj=c(3,j)-zi
3992           rij=xj*xj+yj*yj+zj*zj
3993           r0ij=r0_scp
3994           r0ijsq=r0ij*r0ij
3995           if (rij.lt.r0ijsq) then
3996             evdwij=0.25d0*(rij-r0ijsq)**2
3997             fac=rij-r0ijsq
3998           else
3999             evdwij=0.0d0
4000             fac=0.0d0
4001           endif
4002           evdw2=evdw2+evdwij
4003 C
4004 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4005 C
4006           ggg(1)=xj*fac
4007           ggg(2)=yj*fac
4008           ggg(3)=zj*fac
4009 cgrad          if (j.lt.i) then
4010 cd          write (iout,*) 'j<i'
4011 C Uncomment following three lines for SC-p interactions
4012 c           do k=1,3
4013 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4014 c           enddo
4015 cgrad          else
4016 cd          write (iout,*) 'j>i'
4017 cgrad            do k=1,3
4018 cgrad              ggg(k)=-ggg(k)
4019 C Uncomment following line for SC-p interactions
4020 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4021 cgrad            enddo
4022 cgrad          endif
4023 cgrad          do k=1,3
4024 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4025 cgrad          enddo
4026 cgrad          kstart=min0(i+1,j)
4027 cgrad          kend=max0(i-1,j-1)
4028 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4029 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4030 cgrad          do k=kstart,kend
4031 cgrad            do l=1,3
4032 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4033 cgrad            enddo
4034 cgrad          enddo
4035           do k=1,3
4036             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4037             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4038           enddo
4039         enddo
4040
4041         enddo ! iint
4042       enddo ! i
4043       return
4044       end
4045 C-----------------------------------------------------------------------------
4046       subroutine escp(evdw2,evdw2_14)
4047 C
4048 C This subroutine calculates the excluded-volume interaction energy between
4049 C peptide-group centers and side chains and its gradient in virtual-bond and
4050 C side-chain vectors.
4051 C
4052       implicit real*8 (a-h,o-z)
4053       include 'DIMENSIONS'
4054       include 'COMMON.GEO'
4055       include 'COMMON.VAR'
4056       include 'COMMON.LOCAL'
4057       include 'COMMON.CHAIN'
4058       include 'COMMON.DERIV'
4059       include 'COMMON.INTERACT'
4060       include 'COMMON.FFIELD'
4061       include 'COMMON.IOUNITS'
4062       include 'COMMON.CONTROL'
4063       dimension ggg(3)
4064       evdw2=0.0D0
4065       evdw2_14=0.0d0
4066 cd    print '(a)','Enter ESCP'
4067 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4068       do i=iatscp_s,iatscp_e
4069         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4070         iteli=itel(i)
4071         xi=0.5D0*(c(1,i)+c(1,i+1))
4072         yi=0.5D0*(c(2,i)+c(2,i+1))
4073         zi=0.5D0*(c(3,i)+c(3,i+1))
4074
4075         do iint=1,nscp_gr(i)
4076
4077         do j=iscpstart(i,iint),iscpend(i,iint)
4078           itypj=iabs(itype(j))
4079           if (itypj.eq.ntyp1) cycle
4080 C Uncomment following three lines for SC-p interactions
4081 c         xj=c(1,nres+j)-xi
4082 c         yj=c(2,nres+j)-yi
4083 c         zj=c(3,nres+j)-zi
4084 C Uncomment following three lines for Ca-p interactions
4085           xj=c(1,j)-xi
4086           yj=c(2,j)-yi
4087           zj=c(3,j)-zi
4088           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4089           fac=rrij**expon2
4090           e1=fac*fac*aad(itypj,iteli)
4091           e2=fac*bad(itypj,iteli)
4092           if (iabs(j-i) .le. 2) then
4093             e1=scal14*e1
4094             e2=scal14*e2
4095             evdw2_14=evdw2_14+e1+e2
4096           endif
4097           evdwij=e1+e2
4098           evdw2=evdw2+evdwij
4099           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4100      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4101      &       bad(itypj,iteli)
4102 C
4103 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4104 C
4105           fac=-(evdwij+e1)*rrij
4106           ggg(1)=xj*fac
4107           ggg(2)=yj*fac
4108           ggg(3)=zj*fac
4109 cgrad          if (j.lt.i) then
4110 cd          write (iout,*) 'j<i'
4111 C Uncomment following three lines for SC-p interactions
4112 c           do k=1,3
4113 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4114 c           enddo
4115 cgrad          else
4116 cd          write (iout,*) 'j>i'
4117 cgrad            do k=1,3
4118 cgrad              ggg(k)=-ggg(k)
4119 C Uncomment following line for SC-p interactions
4120 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4121 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4122 cgrad            enddo
4123 cgrad          endif
4124 cgrad          do k=1,3
4125 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4126 cgrad          enddo
4127 cgrad          kstart=min0(i+1,j)
4128 cgrad          kend=max0(i-1,j-1)
4129 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4130 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4131 cgrad          do k=kstart,kend
4132 cgrad            do l=1,3
4133 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4134 cgrad            enddo
4135 cgrad          enddo
4136           do k=1,3
4137             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4138             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4139           enddo
4140         enddo
4141
4142         enddo ! iint
4143       enddo ! i
4144       do i=1,nct
4145         do j=1,3
4146           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4147           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4148           gradx_scp(j,i)=expon*gradx_scp(j,i)
4149         enddo
4150       enddo
4151 C******************************************************************************
4152 C
4153 C                              N O T E !!!
4154 C
4155 C To save time the factor EXPON has been extracted from ALL components
4156 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4157 C use!
4158 C
4159 C******************************************************************************
4160       return
4161       end
4162 C--------------------------------------------------------------------------
4163       subroutine edis(ehpb)
4164 C
4165 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4166 C
4167       implicit real*8 (a-h,o-z)
4168       include 'DIMENSIONS'
4169       include 'COMMON.SBRIDGE'
4170       include 'COMMON.CHAIN'
4171       include 'COMMON.DERIV'
4172       include 'COMMON.VAR'
4173       include 'COMMON.INTERACT'
4174       include 'COMMON.IOUNITS'
4175       dimension ggg(3)
4176       ehpb=0.0D0
4177 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4178 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4179       if (link_end.eq.0) return
4180       do i=link_start,link_end
4181 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4182 C CA-CA distance used in regularization of structure.
4183         ii=ihpb(i)
4184         jj=jhpb(i)
4185 C iii and jjj point to the residues for which the distance is assigned.
4186         if (ii.gt.nres) then
4187           iii=ii-nres
4188           jjj=jj-nres
4189         else
4190           iii=ii
4191           jjj=jj
4192         endif
4193 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4194 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4195 C    distance and angle dependent SS bond potential.
4196         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4197      & iabs(itype(jjj)).eq.1) then
4198           call ssbond_ene(iii,jjj,eij)
4199           ehpb=ehpb+2*eij
4200 cd          write (iout,*) "eij",eij
4201         else
4202 C Calculate the distance between the two points and its difference from the
4203 C target distance.
4204         dd=dist(ii,jj)
4205         rdis=dd-dhpb(i)
4206 C Get the force constant corresponding to this distance.
4207         waga=forcon(i)
4208 C Calculate the contribution to energy.
4209         ehpb=ehpb+waga*rdis*rdis
4210 C
4211 C Evaluate gradient.
4212 C
4213         fac=waga*rdis/dd
4214 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4215 cd   &   ' waga=',waga,' fac=',fac
4216         do j=1,3
4217           ggg(j)=fac*(c(j,jj)-c(j,ii))
4218         enddo
4219 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4220 C If this is a SC-SC distance, we need to calculate the contributions to the
4221 C Cartesian gradient in the SC vectors (ghpbx).
4222         if (iii.lt.ii) then
4223           do j=1,3
4224             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4225             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4226           enddo
4227         endif
4228 cgrad        do j=iii,jjj-1
4229 cgrad          do k=1,3
4230 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4231 cgrad          enddo
4232 cgrad        enddo
4233         do k=1,3
4234           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4235           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4236         enddo
4237         endif
4238       enddo
4239       ehpb=0.5D0*ehpb
4240       return
4241       end
4242 C--------------------------------------------------------------------------
4243       subroutine ssbond_ene(i,j,eij)
4244 C
4245 C Calculate the distance and angle dependent SS-bond potential energy
4246 C using a free-energy function derived based on RHF/6-31G** ab initio
4247 C calculations of diethyl disulfide.
4248 C
4249 C A. Liwo and U. Kozlowska, 11/24/03
4250 C
4251       implicit real*8 (a-h,o-z)
4252       include 'DIMENSIONS'
4253       include 'COMMON.SBRIDGE'
4254       include 'COMMON.CHAIN'
4255       include 'COMMON.DERIV'
4256       include 'COMMON.LOCAL'
4257       include 'COMMON.INTERACT'
4258       include 'COMMON.VAR'
4259       include 'COMMON.IOUNITS'
4260       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4261       itypi=iabs(itype(i))
4262       xi=c(1,nres+i)
4263       yi=c(2,nres+i)
4264       zi=c(3,nres+i)
4265       dxi=dc_norm(1,nres+i)
4266       dyi=dc_norm(2,nres+i)
4267       dzi=dc_norm(3,nres+i)
4268 c      dsci_inv=dsc_inv(itypi)
4269       dsci_inv=vbld_inv(nres+i)
4270       itypj=iabs(itype(j))
4271 c      dscj_inv=dsc_inv(itypj)
4272       dscj_inv=vbld_inv(nres+j)
4273       xj=c(1,nres+j)-xi
4274       yj=c(2,nres+j)-yi
4275       zj=c(3,nres+j)-zi
4276       dxj=dc_norm(1,nres+j)
4277       dyj=dc_norm(2,nres+j)
4278       dzj=dc_norm(3,nres+j)
4279       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4280       rij=dsqrt(rrij)
4281       erij(1)=xj*rij
4282       erij(2)=yj*rij
4283       erij(3)=zj*rij
4284       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4285       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4286       om12=dxi*dxj+dyi*dyj+dzi*dzj
4287       do k=1,3
4288         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4289         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4290       enddo
4291       rij=1.0d0/rij
4292       deltad=rij-d0cm
4293       deltat1=1.0d0-om1
4294       deltat2=1.0d0+om2
4295       deltat12=om2-om1+2.0d0
4296       cosphi=om12-om1*om2
4297       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4298      &  +akct*deltad*deltat12
4299      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4300 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4301 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4302 c     &  " deltat12",deltat12," eij",eij
4303       ed=2*akcm*deltad+akct*deltat12
4304       pom1=akct*deltad
4305       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4306       eom1=-2*akth*deltat1-pom1-om2*pom2
4307       eom2= 2*akth*deltat2+pom1-om1*pom2
4308       eom12=pom2
4309       do k=1,3
4310         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4311         ghpbx(k,i)=ghpbx(k,i)-ggk
4312      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4313      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4314         ghpbx(k,j)=ghpbx(k,j)+ggk
4315      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4316      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4317         ghpbc(k,i)=ghpbc(k,i)-ggk
4318         ghpbc(k,j)=ghpbc(k,j)+ggk
4319       enddo
4320 C
4321 C Calculate the components of the gradient in DC and X
4322 C
4323 cgrad      do k=i,j-1
4324 cgrad        do l=1,3
4325 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4326 cgrad        enddo
4327 cgrad      enddo
4328       return
4329       end
4330 C--------------------------------------------------------------------------
4331       subroutine ebond(estr)
4332 c
4333 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4334 c
4335       implicit real*8 (a-h,o-z)
4336       include 'DIMENSIONS'
4337       include 'COMMON.LOCAL'
4338       include 'COMMON.GEO'
4339       include 'COMMON.INTERACT'
4340       include 'COMMON.DERIV'
4341       include 'COMMON.VAR'
4342       include 'COMMON.CHAIN'
4343       include 'COMMON.IOUNITS'
4344       include 'COMMON.NAMES'
4345       include 'COMMON.FFIELD'
4346       include 'COMMON.CONTROL'
4347       include 'COMMON.SETUP'
4348       double precision u(3),ud(3)
4349       estr=0.0d0
4350       estr1=0.0d0
4351       do i=ibondp_start,ibondp_end
4352         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4353           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4354           do j=1,3
4355           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4356      &      *dc(j,i-1)/vbld(i)
4357           enddo
4358           if (energy_dec) write(iout,*)
4359      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4360         else
4361         diff = vbld(i)-vbldp0
4362         if (energy_dec) write (iout,*)
4363      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4364         estr=estr+diff*diff
4365         do j=1,3
4366           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4367         enddo
4368 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4369         endif
4370       enddo
4371       estr=0.5d0*AKP*estr+estr1
4372 c
4373 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4374 c
4375       do i=ibond_start,ibond_end
4376         iti=iabs(itype(i))
4377         if (iti.ne.10 .and. iti.ne.ntyp1) then
4378           nbi=nbondterm(iti)
4379           if (nbi.eq.1) then
4380             diff=vbld(i+nres)-vbldsc0(1,iti)
4381             if (energy_dec) write (iout,*)
4382      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4383      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4384             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4385             do j=1,3
4386               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4387             enddo
4388           else
4389             do j=1,nbi
4390               diff=vbld(i+nres)-vbldsc0(j,iti)
4391               ud(j)=aksc(j,iti)*diff
4392               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4393             enddo
4394             uprod=u(1)
4395             do j=2,nbi
4396               uprod=uprod*u(j)
4397             enddo
4398             usum=0.0d0
4399             usumsqder=0.0d0
4400             do j=1,nbi
4401               uprod1=1.0d0
4402               uprod2=1.0d0
4403               do k=1,nbi
4404                 if (k.ne.j) then
4405                   uprod1=uprod1*u(k)
4406                   uprod2=uprod2*u(k)*u(k)
4407                 endif
4408               enddo
4409               usum=usum+uprod1
4410               usumsqder=usumsqder+ud(j)*uprod2
4411             enddo
4412             estr=estr+uprod/usum
4413             do j=1,3
4414              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4415             enddo
4416           endif
4417         endif
4418       enddo
4419       return
4420       end
4421 #ifdef CRYST_THETA
4422 C--------------------------------------------------------------------------
4423       subroutine ebend(etheta)
4424 C
4425 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4426 C angles gamma and its derivatives in consecutive thetas and gammas.
4427 C
4428       implicit real*8 (a-h,o-z)
4429       include 'DIMENSIONS'
4430       include 'COMMON.LOCAL'
4431       include 'COMMON.GEO'
4432       include 'COMMON.INTERACT'
4433       include 'COMMON.DERIV'
4434       include 'COMMON.VAR'
4435       include 'COMMON.CHAIN'
4436       include 'COMMON.IOUNITS'
4437       include 'COMMON.NAMES'
4438       include 'COMMON.FFIELD'
4439       include 'COMMON.CONTROL'
4440       common /calcthet/ term1,term2,termm,diffak,ratak,
4441      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4442      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4443       double precision y(2),z(2)
4444       delta=0.02d0*pi
4445 c      time11=dexp(-2*time)
4446 c      time12=1.0d0
4447       etheta=0.0D0
4448 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4449       do i=ithet_start,ithet_end
4450         if (itype(i-1).eq.ntyp1) cycle
4451 C Zero the energy function and its derivative at 0 or pi.
4452         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4453         it=itype(i-1)
4454         ichir1=isign(1,itype(i-2))
4455         ichir2=isign(1,itype(i))
4456          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4457          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4458          if (itype(i-1).eq.10) then
4459           itype1=isign(10,itype(i-2))
4460           ichir11=isign(1,itype(i-2))
4461           ichir12=isign(1,itype(i-2))
4462           itype2=isign(10,itype(i))
4463           ichir21=isign(1,itype(i))
4464           ichir22=isign(1,itype(i))
4465          endif
4466
4467         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4468 #ifdef OSF
4469           phii=phi(i)
4470           if (phii.ne.phii) phii=150.0
4471 #else
4472           phii=phi(i)
4473 #endif
4474           y(1)=dcos(phii)
4475           y(2)=dsin(phii)
4476         else
4477           y(1)=0.0D0
4478           y(2)=0.0D0
4479         endif
4480         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4481 #ifdef OSF
4482           phii1=phi(i+1)
4483           if (phii1.ne.phii1) phii1=150.0
4484           phii1=pinorm(phii1)
4485           z(1)=cos(phii1)
4486 #else
4487           phii1=phi(i+1)
4488           z(1)=dcos(phii1)
4489 #endif
4490           z(2)=dsin(phii1)
4491         else
4492           z(1)=0.0D0
4493           z(2)=0.0D0
4494         endif
4495 C Calculate the "mean" value of theta from the part of the distribution
4496 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4497 C In following comments this theta will be referred to as t_c.
4498         thet_pred_mean=0.0d0
4499         do k=1,2
4500             athetk=athet(k,it,ichir1,ichir2)
4501             bthetk=bthet(k,it,ichir1,ichir2)
4502           if (it.eq.10) then
4503              athetk=athet(k,itype1,ichir11,ichir12)
4504              bthetk=bthet(k,itype2,ichir21,ichir22)
4505           endif
4506          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4507         enddo
4508         dthett=thet_pred_mean*ssd
4509         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4510 C Derivatives of the "mean" values in gamma1 and gamma2.
4511         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4512      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4513          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4514      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4515          if (it.eq.10) then
4516       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4517      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4518         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4519      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4520          endif
4521         if (theta(i).gt.pi-delta) then
4522           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4523      &         E_tc0)
4524           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4525           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4526           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4527      &        E_theta)
4528           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4529      &        E_tc)
4530         else if (theta(i).lt.delta) then
4531           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4532           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4533           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4534      &        E_theta)
4535           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4536           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4537      &        E_tc)
4538         else
4539           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4540      &        E_theta,E_tc)
4541         endif
4542         etheta=etheta+ethetai
4543         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4544      &      'ebend',i,ethetai
4545         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4546         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4547         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4548       enddo
4549 C Ufff.... We've done all this!!!
4550       return
4551       end
4552 C---------------------------------------------------------------------------
4553       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4554      &     E_tc)
4555       implicit real*8 (a-h,o-z)
4556       include 'DIMENSIONS'
4557       include 'COMMON.LOCAL'
4558       include 'COMMON.IOUNITS'
4559       common /calcthet/ term1,term2,termm,diffak,ratak,
4560      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4561      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4562 C Calculate the contributions to both Gaussian lobes.
4563 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4564 C The "polynomial part" of the "standard deviation" of this part of
4565 C the distribution.
4566         sig=polthet(3,it)
4567         do j=2,0,-1
4568           sig=sig*thet_pred_mean+polthet(j,it)
4569         enddo
4570 C Derivative of the "interior part" of the "standard deviation of the"
4571 C gamma-dependent Gaussian lobe in t_c.
4572         sigtc=3*polthet(3,it)
4573         do j=2,1,-1
4574           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4575         enddo
4576         sigtc=sig*sigtc
4577 C Set the parameters of both Gaussian lobes of the distribution.
4578 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4579         fac=sig*sig+sigc0(it)
4580         sigcsq=fac+fac
4581         sigc=1.0D0/sigcsq
4582 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4583         sigsqtc=-4.0D0*sigcsq*sigtc
4584 c       print *,i,sig,sigtc,sigsqtc
4585 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4586         sigtc=-sigtc/(fac*fac)
4587 C Following variable is sigma(t_c)**(-2)
4588         sigcsq=sigcsq*sigcsq
4589         sig0i=sig0(it)
4590         sig0inv=1.0D0/sig0i**2
4591         delthec=thetai-thet_pred_mean
4592         delthe0=thetai-theta0i
4593         term1=-0.5D0*sigcsq*delthec*delthec
4594         term2=-0.5D0*sig0inv*delthe0*delthe0
4595 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4596 C NaNs in taking the logarithm. We extract the largest exponent which is added
4597 C to the energy (this being the log of the distribution) at the end of energy
4598 C term evaluation for this virtual-bond angle.
4599         if (term1.gt.term2) then
4600           termm=term1
4601           term2=dexp(term2-termm)
4602           term1=1.0d0
4603         else
4604           termm=term2
4605           term1=dexp(term1-termm)
4606           term2=1.0d0
4607         endif
4608 C The ratio between the gamma-independent and gamma-dependent lobes of
4609 C the distribution is a Gaussian function of thet_pred_mean too.
4610         diffak=gthet(2,it)-thet_pred_mean
4611         ratak=diffak/gthet(3,it)**2
4612         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4613 C Let's differentiate it in thet_pred_mean NOW.
4614         aktc=ak*ratak
4615 C Now put together the distribution terms to make complete distribution.
4616         termexp=term1+ak*term2
4617         termpre=sigc+ak*sig0i
4618 C Contribution of the bending energy from this theta is just the -log of
4619 C the sum of the contributions from the two lobes and the pre-exponential
4620 C factor. Simple enough, isn't it?
4621         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4622 C NOW the derivatives!!!
4623 C 6/6/97 Take into account the deformation.
4624         E_theta=(delthec*sigcsq*term1
4625      &       +ak*delthe0*sig0inv*term2)/termexp
4626         E_tc=((sigtc+aktc*sig0i)/termpre
4627      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4628      &       aktc*term2)/termexp)
4629       return
4630       end
4631 c-----------------------------------------------------------------------------
4632       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4633       implicit real*8 (a-h,o-z)
4634       include 'DIMENSIONS'
4635       include 'COMMON.LOCAL'
4636       include 'COMMON.IOUNITS'
4637       common /calcthet/ term1,term2,termm,diffak,ratak,
4638      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4639      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4640       delthec=thetai-thet_pred_mean
4641       delthe0=thetai-theta0i
4642 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4643       t3 = thetai-thet_pred_mean
4644       t6 = t3**2
4645       t9 = term1
4646       t12 = t3*sigcsq
4647       t14 = t12+t6*sigsqtc
4648       t16 = 1.0d0
4649       t21 = thetai-theta0i
4650       t23 = t21**2
4651       t26 = term2
4652       t27 = t21*t26
4653       t32 = termexp
4654       t40 = t32**2
4655       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4656      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4657      & *(-t12*t9-ak*sig0inv*t27)
4658       return
4659       end
4660 #else
4661 C--------------------------------------------------------------------------
4662       subroutine ebend(etheta)
4663 C
4664 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4665 C angles gamma and its derivatives in consecutive thetas and gammas.
4666 C ab initio-derived potentials from
4667 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4668 C
4669       implicit real*8 (a-h,o-z)
4670       include 'DIMENSIONS'
4671       include 'COMMON.LOCAL'
4672       include 'COMMON.GEO'
4673       include 'COMMON.INTERACT'
4674       include 'COMMON.DERIV'
4675       include 'COMMON.VAR'
4676       include 'COMMON.CHAIN'
4677       include 'COMMON.IOUNITS'
4678       include 'COMMON.NAMES'
4679       include 'COMMON.FFIELD'
4680       include 'COMMON.CONTROL'
4681       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4682      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4683      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4684      & sinph1ph2(maxdouble,maxdouble)
4685       logical lprn /.false./, lprn1 /.false./
4686       etheta=0.0D0
4687       do i=ithet_start,ithet_end
4688         if (itype(i-1).eq.ntyp1) cycle
4689         if (iabs(itype(i+1)).eq.20) iblock=2
4690         if (iabs(itype(i+1)).ne.20) iblock=1
4691         dethetai=0.0d0
4692         dephii=0.0d0
4693         dephii1=0.0d0
4694         theti2=0.5d0*theta(i)
4695         ityp2=ithetyp((itype(i-1)))
4696         do k=1,nntheterm
4697           coskt(k)=dcos(k*theti2)
4698           sinkt(k)=dsin(k*theti2)
4699         enddo
4700         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4701 #ifdef OSF
4702           phii=phi(i)
4703           if (phii.ne.phii) phii=150.0
4704 #else
4705           phii=phi(i)
4706 #endif
4707           ityp1=ithetyp((itype(i-2)))
4708 C propagation of chirality for glycine type
4709           do k=1,nsingle
4710             cosph1(k)=dcos(k*phii)
4711             sinph1(k)=dsin(k*phii)
4712           enddo
4713         else
4714           phii=0.0d0
4715           ityp1=nthetyp+1
4716           do k=1,nsingle
4717             cosph1(k)=0.0d0
4718             sinph1(k)=0.0d0
4719           enddo
4720         endif
4721         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4722 #ifdef OSF
4723           phii1=phi(i+1)
4724           if (phii1.ne.phii1) phii1=150.0
4725           phii1=pinorm(phii1)
4726 #else
4727           phii1=phi(i+1)
4728 #endif
4729           ityp3=ithetyp((itype(i)))
4730           do k=1,nsingle
4731             cosph2(k)=dcos(k*phii1)
4732             sinph2(k)=dsin(k*phii1)
4733           enddo
4734         else
4735           phii1=0.0d0
4736           ityp3=nthetyp+1
4737           do k=1,nsingle
4738             cosph2(k)=0.0d0
4739             sinph2(k)=0.0d0
4740           enddo
4741         endif
4742         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4743         do k=1,ndouble
4744           do l=1,k-1
4745             ccl=cosph1(l)*cosph2(k-l)
4746             ssl=sinph1(l)*sinph2(k-l)
4747             scl=sinph1(l)*cosph2(k-l)
4748             csl=cosph1(l)*sinph2(k-l)
4749             cosph1ph2(l,k)=ccl-ssl
4750             cosph1ph2(k,l)=ccl+ssl
4751             sinph1ph2(l,k)=scl+csl
4752             sinph1ph2(k,l)=scl-csl
4753           enddo
4754         enddo
4755         if (lprn) then
4756         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4757      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4758         write (iout,*) "coskt and sinkt"
4759         do k=1,nntheterm
4760           write (iout,*) k,coskt(k),sinkt(k)
4761         enddo
4762         endif
4763         do k=1,ntheterm
4764           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4765           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4766      &      *coskt(k)
4767           if (lprn)
4768      &    write (iout,*) "k",k,"
4769      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4770      &     " ethetai",ethetai
4771         enddo
4772         if (lprn) then
4773         write (iout,*) "cosph and sinph"
4774         do k=1,nsingle
4775           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4776         enddo
4777         write (iout,*) "cosph1ph2 and sinph2ph2"
4778         do k=2,ndouble
4779           do l=1,k-1
4780             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4781      &         sinph1ph2(l,k),sinph1ph2(k,l)
4782           enddo
4783         enddo
4784         write(iout,*) "ethetai",ethetai
4785         endif
4786         do m=1,ntheterm2
4787           do k=1,nsingle
4788             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4789      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4790      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4791      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4792             ethetai=ethetai+sinkt(m)*aux
4793             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4794             dephii=dephii+k*sinkt(m)*(
4795      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4796      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4797             dephii1=dephii1+k*sinkt(m)*(
4798      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4799      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4800             if (lprn)
4801      &      write (iout,*) "m",m," k",k," bbthet",
4802      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4803      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4804      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4805      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4806           enddo
4807         enddo
4808         if (lprn)
4809      &  write(iout,*) "ethetai",ethetai
4810         do m=1,ntheterm3
4811           do k=2,ndouble
4812             do l=1,k-1
4813               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4814      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4815      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4816      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4817               ethetai=ethetai+sinkt(m)*aux
4818               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4819               dephii=dephii+l*sinkt(m)*(
4820      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4821      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4822      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4823      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4824               dephii1=dephii1+(k-l)*sinkt(m)*(
4825      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4826      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4827      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4828      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4829               if (lprn) then
4830               write (iout,*) "m",m," k",k," l",l," ffthet",
4831      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4832      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4833      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4834      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4835      &            " ethetai",ethetai
4836               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4837      &            cosph1ph2(k,l)*sinkt(m),
4838      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4839               endif
4840             enddo
4841           enddo
4842         enddo
4843 10      continue
4844 c        lprn1=.true.
4845         if (lprn1)
4846      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4847      &   i,theta(i)*rad2deg,phii*rad2deg,
4848      &   phii1*rad2deg,ethetai
4849 c        lprn1=.false.
4850         etheta=etheta+ethetai
4851         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4852         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4853         gloc(nphi+i-2,icg)=wang*dethetai
4854       enddo
4855       return
4856       end
4857 #endif
4858 #ifdef CRYST_SC
4859 c-----------------------------------------------------------------------------
4860       subroutine esc(escloc)
4861 C Calculate the local energy of a side chain and its derivatives in the
4862 C corresponding virtual-bond valence angles THETA and the spherical angles
4863 C ALPHA and OMEGA.
4864       implicit real*8 (a-h,o-z)
4865       include 'DIMENSIONS'
4866       include 'COMMON.GEO'
4867       include 'COMMON.LOCAL'
4868       include 'COMMON.VAR'
4869       include 'COMMON.INTERACT'
4870       include 'COMMON.DERIV'
4871       include 'COMMON.CHAIN'
4872       include 'COMMON.IOUNITS'
4873       include 'COMMON.NAMES'
4874       include 'COMMON.FFIELD'
4875       include 'COMMON.CONTROL'
4876       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4877      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4878       common /sccalc/ time11,time12,time112,theti,it,nlobit
4879       delta=0.02d0*pi
4880       escloc=0.0D0
4881 c     write (iout,'(a)') 'ESC'
4882       do i=loc_start,loc_end
4883         it=itype(i)
4884         if (it.eq.ntyp1) cycle
4885         if (it.eq.10) goto 1
4886         nlobit=nlob(iabs(it))
4887 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4888 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4889         theti=theta(i+1)-pipol
4890         x(1)=dtan(theti)
4891         x(2)=alph(i)
4892         x(3)=omeg(i)
4893
4894         if (x(2).gt.pi-delta) then
4895           xtemp(1)=x(1)
4896           xtemp(2)=pi-delta
4897           xtemp(3)=x(3)
4898           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4899           xtemp(2)=pi
4900           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4901           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4902      &        escloci,dersc(2))
4903           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4904      &        ddersc0(1),dersc(1))
4905           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4906      &        ddersc0(3),dersc(3))
4907           xtemp(2)=pi-delta
4908           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4909           xtemp(2)=pi
4910           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4911           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4912      &            dersc0(2),esclocbi,dersc02)
4913           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4914      &            dersc12,dersc01)
4915           call splinthet(x(2),0.5d0*delta,ss,ssd)
4916           dersc0(1)=dersc01
4917           dersc0(2)=dersc02
4918           dersc0(3)=0.0d0
4919           do k=1,3
4920             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4921           enddo
4922           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4923 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4924 c    &             esclocbi,ss,ssd
4925           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4926 c         escloci=esclocbi
4927 c         write (iout,*) escloci
4928         else if (x(2).lt.delta) then
4929           xtemp(1)=x(1)
4930           xtemp(2)=delta
4931           xtemp(3)=x(3)
4932           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4933           xtemp(2)=0.0d0
4934           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4935           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4936      &        escloci,dersc(2))
4937           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4938      &        ddersc0(1),dersc(1))
4939           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4940      &        ddersc0(3),dersc(3))
4941           xtemp(2)=delta
4942           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4943           xtemp(2)=0.0d0
4944           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4945           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4946      &            dersc0(2),esclocbi,dersc02)
4947           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4948      &            dersc12,dersc01)
4949           dersc0(1)=dersc01
4950           dersc0(2)=dersc02
4951           dersc0(3)=0.0d0
4952           call splinthet(x(2),0.5d0*delta,ss,ssd)
4953           do k=1,3
4954             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4955           enddo
4956           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4957 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4958 c    &             esclocbi,ss,ssd
4959           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4960 c         write (iout,*) escloci
4961         else
4962           call enesc(x,escloci,dersc,ddummy,.false.)
4963         endif
4964
4965         escloc=escloc+escloci
4966         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4967      &     'escloc',i,escloci
4968 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4969
4970         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4971      &   wscloc*dersc(1)
4972         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4973         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4974     1   continue
4975       enddo
4976       return
4977       end
4978 C---------------------------------------------------------------------------
4979       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4980       implicit real*8 (a-h,o-z)
4981       include 'DIMENSIONS'
4982       include 'COMMON.GEO'
4983       include 'COMMON.LOCAL'
4984       include 'COMMON.IOUNITS'
4985       common /sccalc/ time11,time12,time112,theti,it,nlobit
4986       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4987       double precision contr(maxlob,-1:1)
4988       logical mixed
4989 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4990         escloc_i=0.0D0
4991         do j=1,3
4992           dersc(j)=0.0D0
4993           if (mixed) ddersc(j)=0.0d0
4994         enddo
4995         x3=x(3)
4996
4997 C Because of periodicity of the dependence of the SC energy in omega we have
4998 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4999 C To avoid underflows, first compute & store the exponents.
5000
5001         do iii=-1,1
5002
5003           x(3)=x3+iii*dwapi
5004
5005           do j=1,nlobit
5006             do k=1,3
5007               z(k)=x(k)-censc(k,j,it)
5008             enddo
5009             do k=1,3
5010               Axk=0.0D0
5011               do l=1,3
5012                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5013               enddo
5014               Ax(k,j,iii)=Axk
5015             enddo
5016             expfac=0.0D0
5017             do k=1,3
5018               expfac=expfac+Ax(k,j,iii)*z(k)
5019             enddo
5020             contr(j,iii)=expfac
5021           enddo ! j
5022
5023         enddo ! iii
5024
5025         x(3)=x3
5026 C As in the case of ebend, we want to avoid underflows in exponentiation and
5027 C subsequent NaNs and INFs in energy calculation.
5028 C Find the largest exponent
5029         emin=contr(1,-1)
5030         do iii=-1,1
5031           do j=1,nlobit
5032             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5033           enddo
5034         enddo
5035         emin=0.5D0*emin
5036 cd      print *,'it=',it,' emin=',emin
5037
5038 C Compute the contribution to SC energy and derivatives
5039         do iii=-1,1
5040
5041           do j=1,nlobit
5042 #ifdef OSF
5043             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5044             if(adexp.ne.adexp) adexp=1.0
5045             expfac=dexp(adexp)
5046 #else
5047             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5048 #endif
5049 cd          print *,'j=',j,' expfac=',expfac
5050             escloc_i=escloc_i+expfac
5051             do k=1,3
5052               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5053             enddo
5054             if (mixed) then
5055               do k=1,3,2
5056                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5057      &            +gaussc(k,2,j,it))*expfac
5058               enddo
5059             endif
5060           enddo
5061
5062         enddo ! iii
5063
5064         dersc(1)=dersc(1)/cos(theti)**2
5065         ddersc(1)=ddersc(1)/cos(theti)**2
5066         ddersc(3)=ddersc(3)
5067
5068         escloci=-(dlog(escloc_i)-emin)
5069         do j=1,3
5070           dersc(j)=dersc(j)/escloc_i
5071         enddo
5072         if (mixed) then
5073           do j=1,3,2
5074             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5075           enddo
5076         endif
5077       return
5078       end
5079 C------------------------------------------------------------------------------
5080       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5081       implicit real*8 (a-h,o-z)
5082       include 'DIMENSIONS'
5083       include 'COMMON.GEO'
5084       include 'COMMON.LOCAL'
5085       include 'COMMON.IOUNITS'
5086       common /sccalc/ time11,time12,time112,theti,it,nlobit
5087       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5088       double precision contr(maxlob)
5089       logical mixed
5090
5091       escloc_i=0.0D0
5092
5093       do j=1,3
5094         dersc(j)=0.0D0
5095       enddo
5096
5097       do j=1,nlobit
5098         do k=1,2
5099           z(k)=x(k)-censc(k,j,it)
5100         enddo
5101         z(3)=dwapi
5102         do k=1,3
5103           Axk=0.0D0
5104           do l=1,3
5105             Axk=Axk+gaussc(l,k,j,it)*z(l)
5106           enddo
5107           Ax(k,j)=Axk
5108         enddo
5109         expfac=0.0D0
5110         do k=1,3
5111           expfac=expfac+Ax(k,j)*z(k)
5112         enddo
5113         contr(j)=expfac
5114       enddo ! j
5115
5116 C As in the case of ebend, we want to avoid underflows in exponentiation and
5117 C subsequent NaNs and INFs in energy calculation.
5118 C Find the largest exponent
5119       emin=contr(1)
5120       do j=1,nlobit
5121         if (emin.gt.contr(j)) emin=contr(j)
5122       enddo
5123       emin=0.5D0*emin
5124
5125 C Compute the contribution to SC energy and derivatives
5126
5127       dersc12=0.0d0
5128       do j=1,nlobit
5129         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5130         escloc_i=escloc_i+expfac
5131         do k=1,2
5132           dersc(k)=dersc(k)+Ax(k,j)*expfac
5133         enddo
5134         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5135      &            +gaussc(1,2,j,it))*expfac
5136         dersc(3)=0.0d0
5137       enddo
5138
5139       dersc(1)=dersc(1)/cos(theti)**2
5140       dersc12=dersc12/cos(theti)**2
5141       escloci=-(dlog(escloc_i)-emin)
5142       do j=1,2
5143         dersc(j)=dersc(j)/escloc_i
5144       enddo
5145       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5146       return
5147       end
5148 #else
5149 c----------------------------------------------------------------------------------
5150       subroutine esc(escloc)
5151 C Calculate the local energy of a side chain and its derivatives in the
5152 C corresponding virtual-bond valence angles THETA and the spherical angles
5153 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5154 C added by Urszula Kozlowska. 07/11/2007
5155 C
5156       implicit real*8 (a-h,o-z)
5157       include 'DIMENSIONS'
5158       include 'COMMON.GEO'
5159       include 'COMMON.LOCAL'
5160       include 'COMMON.VAR'
5161       include 'COMMON.SCROT'
5162       include 'COMMON.INTERACT'
5163       include 'COMMON.DERIV'
5164       include 'COMMON.CHAIN'
5165       include 'COMMON.IOUNITS'
5166       include 'COMMON.NAMES'
5167       include 'COMMON.FFIELD'
5168       include 'COMMON.CONTROL'
5169       include 'COMMON.VECTORS'
5170       double precision x_prime(3),y_prime(3),z_prime(3)
5171      &    , sumene,dsc_i,dp2_i,x(65),
5172      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5173      &    de_dxx,de_dyy,de_dzz,de_dt
5174       double precision s1_t,s1_6_t,s2_t,s2_6_t
5175       double precision
5176      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5177      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5178      & dt_dCi(3),dt_dCi1(3)
5179       common /sccalc/ time11,time12,time112,theti,it,nlobit
5180       delta=0.02d0*pi
5181       escloc=0.0D0
5182       do i=loc_start,loc_end
5183         if (itype(i).eq.ntyp1) cycle
5184         costtab(i+1) =dcos(theta(i+1))
5185         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5186         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5187         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5188         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5189         cosfac=dsqrt(cosfac2)
5190         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5191         sinfac=dsqrt(sinfac2)
5192         it=iabs(itype(i))
5193         if (it.eq.10) goto 1
5194 c
5195 C  Compute the axes of tghe local cartesian coordinates system; store in
5196 c   x_prime, y_prime and z_prime
5197 c
5198         do j=1,3
5199           x_prime(j) = 0.00
5200           y_prime(j) = 0.00
5201           z_prime(j) = 0.00
5202         enddo
5203 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5204 C     &   dc_norm(3,i+nres)
5205         do j = 1,3
5206           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5207           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5208         enddo
5209         do j = 1,3
5210           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5211         enddo
5212 c       write (2,*) "i",i
5213 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5214 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5215 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5216 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5217 c      & " xy",scalar(x_prime(1),y_prime(1)),
5218 c      & " xz",scalar(x_prime(1),z_prime(1)),
5219 c      & " yy",scalar(y_prime(1),y_prime(1)),
5220 c      & " yz",scalar(y_prime(1),z_prime(1)),
5221 c      & " zz",scalar(z_prime(1),z_prime(1))
5222 c
5223 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5224 C to local coordinate system. Store in xx, yy, zz.
5225 c
5226         xx=0.0d0
5227         yy=0.0d0
5228         zz=0.0d0
5229         do j = 1,3
5230           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5231           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5232           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5233         enddo
5234
5235         xxtab(i)=xx
5236         yytab(i)=yy
5237         zztab(i)=zz
5238 C
5239 C Compute the energy of the ith side cbain
5240 C
5241 c        write (2,*) "xx",xx," yy",yy," zz",zz
5242         it=iabs(itype(i))
5243         do j = 1,65
5244           x(j) = sc_parmin(j,it)
5245         enddo
5246 #ifdef CHECK_COORD
5247 Cc diagnostics - remove later
5248         xx1 = dcos(alph(2))
5249         yy1 = dsin(alph(2))*dcos(omeg(2))
5250         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5251         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5252      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5253      &    xx1,yy1,zz1
5254 C,"  --- ", xx_w,yy_w,zz_w
5255 c end diagnostics
5256 #endif
5257         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5258      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5259      &   + x(10)*yy*zz
5260         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5261      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5262      & + x(20)*yy*zz
5263         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5264      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5265      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5266      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5267      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5268      &  +x(40)*xx*yy*zz
5269         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5270      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5271      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5272      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5273      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5274      &  +x(60)*xx*yy*zz
5275         dsc_i   = 0.743d0+x(61)
5276         dp2_i   = 1.9d0+x(62)
5277         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5278      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5279         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5280      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5281         s1=(1+x(63))/(0.1d0 + dscp1)
5282         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5283         s2=(1+x(65))/(0.1d0 + dscp2)
5284         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5285         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5286      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5287 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5288 c     &   sumene4,
5289 c     &   dscp1,dscp2,sumene
5290 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5291         escloc = escloc + sumene
5292 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5293 c     & ,zz,xx,yy
5294 c#define DEBUG
5295 #ifdef DEBUG
5296 C
5297 C This section to check the numerical derivatives of the energy of ith side
5298 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5299 C #define DEBUG in the code to turn it on.
5300 C
5301         write (2,*) "sumene               =",sumene
5302         aincr=1.0d-7
5303         xxsave=xx
5304         xx=xx+aincr
5305         write (2,*) xx,yy,zz
5306         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5307         de_dxx_num=(sumenep-sumene)/aincr
5308         xx=xxsave
5309         write (2,*) "xx+ sumene from enesc=",sumenep
5310         yysave=yy
5311         yy=yy+aincr
5312         write (2,*) xx,yy,zz
5313         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5314         de_dyy_num=(sumenep-sumene)/aincr
5315         yy=yysave
5316         write (2,*) "yy+ sumene from enesc=",sumenep
5317         zzsave=zz
5318         zz=zz+aincr
5319         write (2,*) xx,yy,zz
5320         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5321         de_dzz_num=(sumenep-sumene)/aincr
5322         zz=zzsave
5323         write (2,*) "zz+ sumene from enesc=",sumenep
5324         costsave=cost2tab(i+1)
5325         sintsave=sint2tab(i+1)
5326         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5327         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5328         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5329         de_dt_num=(sumenep-sumene)/aincr
5330         write (2,*) " t+ sumene from enesc=",sumenep
5331         cost2tab(i+1)=costsave
5332         sint2tab(i+1)=sintsave
5333 C End of diagnostics section.
5334 #endif
5335 C
5336 C Compute the gradient of esc
5337 C
5338 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5339         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5340         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5341         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5342         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5343         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5344         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5345         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5346         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5347         pom1=(sumene3*sint2tab(i+1)+sumene1)
5348      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5349         pom2=(sumene4*cost2tab(i+1)+sumene2)
5350      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5351         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5352         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5353      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5354      &  +x(40)*yy*zz
5355         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5356         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5357      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5358      &  +x(60)*yy*zz
5359         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5360      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5361      &        +(pom1+pom2)*pom_dx
5362 #ifdef DEBUG
5363         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5364 #endif
5365 C
5366         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5367         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5368      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5369      &  +x(40)*xx*zz
5370         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5371         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5372      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5373      &  +x(59)*zz**2 +x(60)*xx*zz
5374         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5375      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5376      &        +(pom1-pom2)*pom_dy
5377 #ifdef DEBUG
5378         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5379 #endif
5380 C
5381         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5382      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5383      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5384      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5385      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5386      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5387      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5388      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5389 #ifdef DEBUG
5390         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5391 #endif
5392 C
5393         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5394      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5395      &  +pom1*pom_dt1+pom2*pom_dt2
5396 #ifdef DEBUG
5397         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5398 #endif
5399 c#undef DEBUG
5400 c
5401 C
5402        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5403        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5404        cosfac2xx=cosfac2*xx
5405        sinfac2yy=sinfac2*yy
5406        do k = 1,3
5407          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5408      &      vbld_inv(i+1)
5409          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5410      &      vbld_inv(i)
5411          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5412          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5413 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5414 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5415 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5416 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5417          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5418          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5419          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5420          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5421          dZZ_Ci1(k)=0.0d0
5422          dZZ_Ci(k)=0.0d0
5423          do j=1,3
5424            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5425      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5426            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5427      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5428          enddo
5429
5430          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5431          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5432          dZZ_XYZ(k)=vbld_inv(i+nres)*
5433      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5434 c
5435          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5436          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5437        enddo
5438
5439        do k=1,3
5440          dXX_Ctab(k,i)=dXX_Ci(k)
5441          dXX_C1tab(k,i)=dXX_Ci1(k)
5442          dYY_Ctab(k,i)=dYY_Ci(k)
5443          dYY_C1tab(k,i)=dYY_Ci1(k)
5444          dZZ_Ctab(k,i)=dZZ_Ci(k)
5445          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5446          dXX_XYZtab(k,i)=dXX_XYZ(k)
5447          dYY_XYZtab(k,i)=dYY_XYZ(k)
5448          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5449        enddo
5450
5451        do k = 1,3
5452 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5453 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5454 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5455 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5456 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5457 c     &    dt_dci(k)
5458 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5459 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5460          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5461      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5462          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5463      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5464          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5465      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5466        enddo
5467 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5468 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5469
5470 C to check gradient call subroutine check_grad
5471
5472     1 continue
5473       enddo
5474       return
5475       end
5476 c------------------------------------------------------------------------------
5477       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5478       implicit none
5479       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5480      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5481       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5482      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5483      &   + x(10)*yy*zz
5484       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5485      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5486      & + x(20)*yy*zz
5487       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5488      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5489      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5490      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5491      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5492      &  +x(40)*xx*yy*zz
5493       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5494      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5495      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5496      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5497      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5498      &  +x(60)*xx*yy*zz
5499       dsc_i   = 0.743d0+x(61)
5500       dp2_i   = 1.9d0+x(62)
5501       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5502      &          *(xx*cost2+yy*sint2))
5503       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5504      &          *(xx*cost2-yy*sint2))
5505       s1=(1+x(63))/(0.1d0 + dscp1)
5506       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5507       s2=(1+x(65))/(0.1d0 + dscp2)
5508       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5509       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5510      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5511       enesc=sumene
5512       return
5513       end
5514 #endif
5515 c------------------------------------------------------------------------------
5516       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5517 C
5518 C This procedure calculates two-body contact function g(rij) and its derivative:
5519 C
5520 C           eps0ij                                     !       x < -1
5521 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5522 C            0                                         !       x > 1
5523 C
5524 C where x=(rij-r0ij)/delta
5525 C
5526 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5527 C
5528       implicit none
5529       double precision rij,r0ij,eps0ij,fcont,fprimcont
5530       double precision x,x2,x4,delta
5531 c     delta=0.02D0*r0ij
5532 c      delta=0.2D0*r0ij
5533       x=(rij-r0ij)/delta
5534       if (x.lt.-1.0D0) then
5535         fcont=eps0ij
5536         fprimcont=0.0D0
5537       else if (x.le.1.0D0) then
5538         x2=x*x
5539         x4=x2*x2
5540         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5541         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5542       else
5543         fcont=0.0D0
5544         fprimcont=0.0D0
5545       endif
5546       return
5547       end
5548 c------------------------------------------------------------------------------
5549       subroutine splinthet(theti,delta,ss,ssder)
5550       implicit real*8 (a-h,o-z)
5551       include 'DIMENSIONS'
5552       include 'COMMON.VAR'
5553       include 'COMMON.GEO'
5554       thetup=pi-delta
5555       thetlow=delta
5556       if (theti.gt.pipol) then
5557         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5558       else
5559         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5560         ssder=-ssder
5561       endif
5562       return
5563       end
5564 c------------------------------------------------------------------------------
5565       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5566       implicit none
5567       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5568       double precision ksi,ksi2,ksi3,a1,a2,a3
5569       a1=fprim0*delta/(f1-f0)
5570       a2=3.0d0-2.0d0*a1
5571       a3=a1-2.0d0
5572       ksi=(x-x0)/delta
5573       ksi2=ksi*ksi
5574       ksi3=ksi2*ksi
5575       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5576       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5577       return
5578       end
5579 c------------------------------------------------------------------------------
5580       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5581       implicit none
5582       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5583       double precision ksi,ksi2,ksi3,a1,a2,a3
5584       ksi=(x-x0)/delta
5585       ksi2=ksi*ksi
5586       ksi3=ksi2*ksi
5587       a1=fprim0x*delta
5588       a2=3*(f1x-f0x)-2*fprim0x*delta
5589       a3=fprim0x*delta-2*(f1x-f0x)
5590       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5591       return
5592       end
5593 C-----------------------------------------------------------------------------
5594 #ifdef CRYST_TOR
5595 C-----------------------------------------------------------------------------
5596       subroutine etor(etors,edihcnstr)
5597       implicit real*8 (a-h,o-z)
5598       include 'DIMENSIONS'
5599       include 'COMMON.VAR'
5600       include 'COMMON.GEO'
5601       include 'COMMON.LOCAL'
5602       include 'COMMON.TORSION'
5603       include 'COMMON.INTERACT'
5604       include 'COMMON.DERIV'
5605       include 'COMMON.CHAIN'
5606       include 'COMMON.NAMES'
5607       include 'COMMON.IOUNITS'
5608       include 'COMMON.FFIELD'
5609       include 'COMMON.TORCNSTR'
5610       include 'COMMON.CONTROL'
5611       logical lprn
5612 C Set lprn=.true. for debugging
5613       lprn=.false.
5614 c      lprn=.true.
5615       etors=0.0D0
5616       do i=iphi_start,iphi_end
5617       etors_ii=0.0D0
5618         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5619      &      .or. itype(i).eq.ntyp1) cycle
5620         itori=itortyp(itype(i-2))
5621         itori1=itortyp(itype(i-1))
5622         phii=phi(i)
5623         gloci=0.0D0
5624 C Proline-Proline pair is a special case...
5625         if (itori.eq.3 .and. itori1.eq.3) then
5626           if (phii.gt.-dwapi3) then
5627             cosphi=dcos(3*phii)
5628             fac=1.0D0/(1.0D0-cosphi)
5629             etorsi=v1(1,3,3)*fac
5630             etorsi=etorsi+etorsi
5631             etors=etors+etorsi-v1(1,3,3)
5632             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5633             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5634           endif
5635           do j=1,3
5636             v1ij=v1(j+1,itori,itori1)
5637             v2ij=v2(j+1,itori,itori1)
5638             cosphi=dcos(j*phii)
5639             sinphi=dsin(j*phii)
5640             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5641             if (energy_dec) etors_ii=etors_ii+
5642      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5643             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5644           enddo
5645         else
5646           do j=1,nterm_old
5647             v1ij=v1(j,itori,itori1)
5648             v2ij=v2(j,itori,itori1)
5649             cosphi=dcos(j*phii)
5650             sinphi=dsin(j*phii)
5651             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5652             if (energy_dec) etors_ii=etors_ii+
5653      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5654             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5655           enddo
5656         endif
5657         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5658              'etor',i,etors_ii
5659         if (lprn)
5660      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5661      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5662      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5663         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5664 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5665       enddo
5666 ! 6/20/98 - dihedral angle constraints
5667       edihcnstr=0.0d0
5668       do i=1,ndih_constr
5669         itori=idih_constr(i)
5670         phii=phi(itori)
5671         difi=phii-phi0(i)
5672         if (difi.gt.drange(i)) then
5673           difi=difi-drange(i)
5674           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5675           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5676         else if (difi.lt.-drange(i)) then
5677           difi=difi+drange(i)
5678           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5679           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5680         endif
5681 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5682 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5683       enddo
5684 !      write (iout,*) 'edihcnstr',edihcnstr
5685       return
5686       end
5687 c------------------------------------------------------------------------------
5688       subroutine etor_d(etors_d)
5689       etors_d=0.0d0
5690       return
5691       end
5692 c----------------------------------------------------------------------------
5693 #else
5694       subroutine etor(etors,edihcnstr)
5695       implicit real*8 (a-h,o-z)
5696       include 'DIMENSIONS'
5697       include 'COMMON.VAR'
5698       include 'COMMON.GEO'
5699       include 'COMMON.LOCAL'
5700       include 'COMMON.TORSION'
5701       include 'COMMON.INTERACT'
5702       include 'COMMON.DERIV'
5703       include 'COMMON.CHAIN'
5704       include 'COMMON.NAMES'
5705       include 'COMMON.IOUNITS'
5706       include 'COMMON.FFIELD'
5707       include 'COMMON.TORCNSTR'
5708       include 'COMMON.CONTROL'
5709       logical lprn
5710 C Set lprn=.true. for debugging
5711       lprn=.false.
5712 c     lprn=.true.
5713       etors=0.0D0
5714       do i=iphi_start,iphi_end
5715         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5716      &       .or. itype(i).eq.ntyp1) cycle
5717         etors_ii=0.0D0
5718          if (iabs(itype(i)).eq.20) then
5719          iblock=2
5720          else
5721          iblock=1
5722          endif
5723         itori=itortyp(itype(i-2))
5724         itori1=itortyp(itype(i-1))
5725         phii=phi(i)
5726         gloci=0.0D0
5727 C Regular cosine and sine terms
5728         do j=1,nterm(itori,itori1,iblock)
5729           v1ij=v1(j,itori,itori1,iblock)
5730           v2ij=v2(j,itori,itori1,iblock)
5731           cosphi=dcos(j*phii)
5732           sinphi=dsin(j*phii)
5733           etors=etors+v1ij*cosphi+v2ij*sinphi
5734           if (energy_dec) etors_ii=etors_ii+
5735      &                v1ij*cosphi+v2ij*sinphi
5736           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5737         enddo
5738 C Lorentz terms
5739 C                         v1
5740 C  E = SUM ----------------------------------- - v1
5741 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5742 C
5743         cosphi=dcos(0.5d0*phii)
5744         sinphi=dsin(0.5d0*phii)
5745         do j=1,nlor(itori,itori1,iblock)
5746           vl1ij=vlor1(j,itori,itori1)
5747           vl2ij=vlor2(j,itori,itori1)
5748           vl3ij=vlor3(j,itori,itori1)
5749           pom=vl2ij*cosphi+vl3ij*sinphi
5750           pom1=1.0d0/(pom*pom+1.0d0)
5751           etors=etors+vl1ij*pom1
5752           if (energy_dec) etors_ii=etors_ii+
5753      &                vl1ij*pom1
5754           pom=-pom*pom1*pom1
5755           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5756         enddo
5757 C Subtract the constant term
5758         etors=etors-v0(itori,itori1,iblock)
5759           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5760      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5761         if (lprn)
5762      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5763      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5764      &  (v1(j,itori,itori1,iblock),j=1,6),
5765      &  (v2(j,itori,itori1,iblock),j=1,6)
5766         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5767 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5768       enddo
5769 ! 6/20/98 - dihedral angle constraints
5770       edihcnstr=0.0d0
5771 c      do i=1,ndih_constr
5772       do i=idihconstr_start,idihconstr_end
5773         itori=idih_constr(i)
5774         phii=phi(itori)
5775         difi=pinorm(phii-phi0(i))
5776         if (difi.gt.drange(i)) then
5777           difi=difi-drange(i)
5778           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5779           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5780         else if (difi.lt.-drange(i)) then
5781           difi=difi+drange(i)
5782           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5783           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5784         else
5785           difi=0.0
5786         endif
5787 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5788 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5789 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5790       enddo
5791 cd       write (iout,*) 'edihcnstr',edihcnstr
5792       return
5793       end
5794 c----------------------------------------------------------------------------
5795       subroutine etor_d(etors_d)
5796 C 6/23/01 Compute double torsional energy
5797       implicit real*8 (a-h,o-z)
5798       include 'DIMENSIONS'
5799       include 'COMMON.VAR'
5800       include 'COMMON.GEO'
5801       include 'COMMON.LOCAL'
5802       include 'COMMON.TORSION'
5803       include 'COMMON.INTERACT'
5804       include 'COMMON.DERIV'
5805       include 'COMMON.CHAIN'
5806       include 'COMMON.NAMES'
5807       include 'COMMON.IOUNITS'
5808       include 'COMMON.FFIELD'
5809       include 'COMMON.TORCNSTR'
5810       logical lprn
5811 C Set lprn=.true. for debugging
5812       lprn=.false.
5813 c     lprn=.true.
5814       etors_d=0.0D0
5815 c      write(iout,*) "a tu??"
5816       do i=iphid_start,iphid_end
5817         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5818      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5819         itori=itortyp(itype(i-2))
5820         itori1=itortyp(itype(i-1))
5821         itori2=itortyp(itype(i))
5822         phii=phi(i)
5823         phii1=phi(i+1)
5824         gloci1=0.0D0
5825         gloci2=0.0D0
5826         iblock=1
5827         if (iabs(itype(i+1)).eq.20) iblock=2
5828
5829 C Regular cosine and sine terms
5830         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5831           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5832           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5833           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5834           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5835           cosphi1=dcos(j*phii)
5836           sinphi1=dsin(j*phii)
5837           cosphi2=dcos(j*phii1)
5838           sinphi2=dsin(j*phii1)
5839           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5840      &     v2cij*cosphi2+v2sij*sinphi2
5841           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5842           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5843         enddo
5844         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5845           do l=1,k-1
5846             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5847             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5848             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5849             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5850             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5851             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5852             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5853             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5854             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5855      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5856             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5857      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5858             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5859      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5860           enddo
5861         enddo
5862         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5863         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5864       enddo
5865       return
5866       end
5867 #endif
5868 c------------------------------------------------------------------------------
5869       subroutine eback_sc_corr(esccor)
5870 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5871 c        conformational states; temporarily implemented as differences
5872 c        between UNRES torsional potentials (dependent on three types of
5873 c        residues) and the torsional potentials dependent on all 20 types
5874 c        of residues computed from AM1  energy surfaces of terminally-blocked
5875 c        amino-acid residues.
5876       implicit real*8 (a-h,o-z)
5877       include 'DIMENSIONS'
5878       include 'COMMON.VAR'
5879       include 'COMMON.GEO'
5880       include 'COMMON.LOCAL'
5881       include 'COMMON.TORSION'
5882       include 'COMMON.SCCOR'
5883       include 'COMMON.INTERACT'
5884       include 'COMMON.DERIV'
5885       include 'COMMON.CHAIN'
5886       include 'COMMON.NAMES'
5887       include 'COMMON.IOUNITS'
5888       include 'COMMON.FFIELD'
5889       include 'COMMON.CONTROL'
5890       logical lprn
5891 C Set lprn=.true. for debugging
5892       lprn=.false.
5893 c      lprn=.true.
5894 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5895       esccor=0.0D0
5896       do i=itau_start,itau_end
5897         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5898         esccor_ii=0.0D0
5899         isccori=isccortyp(itype(i-2))
5900         isccori1=isccortyp(itype(i-1))
5901 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5902         phii=phi(i)
5903         do intertyp=1,3 !intertyp
5904 cc Added 09 May 2012 (Adasko)
5905 cc  Intertyp means interaction type of backbone mainchain correlation:
5906 c   1 = SC...Ca...Ca...Ca
5907 c   2 = Ca...Ca...Ca...SC
5908 c   3 = SC...Ca...Ca...SCi
5909         gloci=0.0D0
5910         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5911      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5912      &      (itype(i-1).eq.ntyp1)))
5913      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5914      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5915      &     .or.(itype(i).eq.ntyp1)))
5916      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5917      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5918      &      (itype(i-3).eq.ntyp1)))) cycle
5919         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5920         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5921      & cycle
5922        do j=1,nterm_sccor(isccori,isccori1)
5923           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5924           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5925           cosphi=dcos(j*tauangle(intertyp,i))
5926           sinphi=dsin(j*tauangle(intertyp,i))
5927           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5928           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5929         enddo
5930 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5931         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5932         if (lprn)
5933      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5934      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5935      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5936      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5937         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5938        enddo !intertyp
5939       enddo
5940
5941       return
5942       end
5943 c----------------------------------------------------------------------------
5944       subroutine multibody(ecorr)
5945 C This subroutine calculates multi-body contributions to energy following
5946 C the idea of Skolnick et al. If side chains I and J make a contact and
5947 C at the same time side chains I+1 and J+1 make a contact, an extra
5948 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5949       implicit real*8 (a-h,o-z)
5950       include 'DIMENSIONS'
5951       include 'COMMON.IOUNITS'
5952       include 'COMMON.DERIV'
5953       include 'COMMON.INTERACT'
5954       include 'COMMON.CONTACTS'
5955       double precision gx(3),gx1(3)
5956       logical lprn
5957
5958 C Set lprn=.true. for debugging
5959       lprn=.false.
5960
5961       if (lprn) then
5962         write (iout,'(a)') 'Contact function values:'
5963         do i=nnt,nct-2
5964           write (iout,'(i2,20(1x,i2,f10.5))')
5965      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5966         enddo
5967       endif
5968       ecorr=0.0D0
5969       do i=nnt,nct
5970         do j=1,3
5971           gradcorr(j,i)=0.0D0
5972           gradxorr(j,i)=0.0D0
5973         enddo
5974       enddo
5975       do i=nnt,nct-2
5976
5977         DO ISHIFT = 3,4
5978
5979         i1=i+ishift
5980         num_conti=num_cont(i)
5981         num_conti1=num_cont(i1)
5982         do jj=1,num_conti
5983           j=jcont(jj,i)
5984           do kk=1,num_conti1
5985             j1=jcont(kk,i1)
5986             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5987 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5988 cd   &                   ' ishift=',ishift
5989 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5990 C The system gains extra energy.
5991               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5992             endif   ! j1==j+-ishift
5993           enddo     ! kk
5994         enddo       ! jj
5995
5996         ENDDO ! ISHIFT
5997
5998       enddo         ! i
5999       return
6000       end
6001 c------------------------------------------------------------------------------
6002       double precision function esccorr(i,j,k,l,jj,kk)
6003       implicit real*8 (a-h,o-z)
6004       include 'DIMENSIONS'
6005       include 'COMMON.IOUNITS'
6006       include 'COMMON.DERIV'
6007       include 'COMMON.INTERACT'
6008       include 'COMMON.CONTACTS'
6009       double precision gx(3),gx1(3)
6010       logical lprn
6011       lprn=.false.
6012       eij=facont(jj,i)
6013       ekl=facont(kk,k)
6014 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6015 C Calculate the multi-body contribution to energy.
6016 C Calculate multi-body contributions to the gradient.
6017 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6018 cd   & k,l,(gacont(m,kk,k),m=1,3)
6019       do m=1,3
6020         gx(m) =ekl*gacont(m,jj,i)
6021         gx1(m)=eij*gacont(m,kk,k)
6022         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6023         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6024         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6025         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6026       enddo
6027       do m=i,j-1
6028         do ll=1,3
6029           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6030         enddo
6031       enddo
6032       do m=k,l-1
6033         do ll=1,3
6034           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6035         enddo
6036       enddo
6037       esccorr=-eij*ekl
6038       return
6039       end
6040 c------------------------------------------------------------------------------
6041       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6042 C This subroutine calculates multi-body contributions to hydrogen-bonding
6043       implicit real*8 (a-h,o-z)
6044       include 'DIMENSIONS'
6045       include 'COMMON.IOUNITS'
6046 #ifdef MPI
6047       include "mpif.h"
6048       parameter (max_cont=maxconts)
6049       parameter (max_dim=26)
6050       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6051       double precision zapas(max_dim,maxconts,max_fg_procs),
6052      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6053       common /przechowalnia/ zapas
6054       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6055      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6056 #endif
6057       include 'COMMON.SETUP'
6058       include 'COMMON.FFIELD'
6059       include 'COMMON.DERIV'
6060       include 'COMMON.INTERACT'
6061       include 'COMMON.CONTACTS'
6062       include 'COMMON.CONTROL'
6063       include 'COMMON.LOCAL'
6064       double precision gx(3),gx1(3),time00
6065       logical lprn,ldone
6066
6067 C Set lprn=.true. for debugging
6068       lprn=.false.
6069 #ifdef MPI
6070       n_corr=0
6071       n_corr1=0
6072       if (nfgtasks.le.1) goto 30
6073       if (lprn) then
6074         write (iout,'(a)') 'Contact function values before RECEIVE:'
6075         do i=nnt,nct-2
6076           write (iout,'(2i3,50(1x,i2,f5.2))')
6077      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6078      &    j=1,num_cont_hb(i))
6079         enddo
6080       endif
6081       call flush(iout)
6082       do i=1,ntask_cont_from
6083         ncont_recv(i)=0
6084       enddo
6085       do i=1,ntask_cont_to
6086         ncont_sent(i)=0
6087       enddo
6088 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6089 c     & ntask_cont_to
6090 C Make the list of contacts to send to send to other procesors
6091 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6092 c      call flush(iout)
6093       do i=iturn3_start,iturn3_end
6094 c        write (iout,*) "make contact list turn3",i," num_cont",
6095 c     &    num_cont_hb(i)
6096         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6097       enddo
6098       do i=iturn4_start,iturn4_end
6099 c        write (iout,*) "make contact list turn4",i," num_cont",
6100 c     &   num_cont_hb(i)
6101         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6102       enddo
6103       do ii=1,nat_sent
6104         i=iat_sent(ii)
6105 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6106 c     &    num_cont_hb(i)
6107         do j=1,num_cont_hb(i)
6108         do k=1,4
6109           jjc=jcont_hb(j,i)
6110           iproc=iint_sent_local(k,jjc,ii)
6111 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6112           if (iproc.gt.0) then
6113             ncont_sent(iproc)=ncont_sent(iproc)+1
6114             nn=ncont_sent(iproc)
6115             zapas(1,nn,iproc)=i
6116             zapas(2,nn,iproc)=jjc
6117             zapas(3,nn,iproc)=facont_hb(j,i)
6118             zapas(4,nn,iproc)=ees0p(j,i)
6119             zapas(5,nn,iproc)=ees0m(j,i)
6120             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6121             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6122             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6123             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6124             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6125             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6126             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6127             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6128             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6129             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6130             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6131             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6132             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6133             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6134             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6135             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6136             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6137             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6138             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6139             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6140             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6141           endif
6142         enddo
6143         enddo
6144       enddo
6145       if (lprn) then
6146       write (iout,*)
6147      &  "Numbers of contacts to be sent to other processors",
6148      &  (ncont_sent(i),i=1,ntask_cont_to)
6149       write (iout,*) "Contacts sent"
6150       do ii=1,ntask_cont_to
6151         nn=ncont_sent(ii)
6152         iproc=itask_cont_to(ii)
6153         write (iout,*) nn," contacts to processor",iproc,
6154      &   " of CONT_TO_COMM group"
6155         do i=1,nn
6156           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6157         enddo
6158       enddo
6159       call flush(iout)
6160       endif
6161       CorrelType=477
6162       CorrelID=fg_rank+1
6163       CorrelType1=478
6164       CorrelID1=nfgtasks+fg_rank+1
6165       ireq=0
6166 C Receive the numbers of needed contacts from other processors
6167       do ii=1,ntask_cont_from
6168         iproc=itask_cont_from(ii)
6169         ireq=ireq+1
6170         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6171      &    FG_COMM,req(ireq),IERR)
6172       enddo
6173 c      write (iout,*) "IRECV ended"
6174 c      call flush(iout)
6175 C Send the number of contacts needed by other processors
6176       do ii=1,ntask_cont_to
6177         iproc=itask_cont_to(ii)
6178         ireq=ireq+1
6179         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6180      &    FG_COMM,req(ireq),IERR)
6181       enddo
6182 c      write (iout,*) "ISEND ended"
6183 c      write (iout,*) "number of requests (nn)",ireq
6184       call flush(iout)
6185       if (ireq.gt.0)
6186      &  call MPI_Waitall(ireq,req,status_array,ierr)
6187 c      write (iout,*)
6188 c     &  "Numbers of contacts to be received from other processors",
6189 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6190 c      call flush(iout)
6191 C Receive contacts
6192       ireq=0
6193       do ii=1,ntask_cont_from
6194         iproc=itask_cont_from(ii)
6195         nn=ncont_recv(ii)
6196 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6197 c     &   " of CONT_TO_COMM group"
6198         call flush(iout)
6199         if (nn.gt.0) then
6200           ireq=ireq+1
6201           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6202      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6203 c          write (iout,*) "ireq,req",ireq,req(ireq)
6204         endif
6205       enddo
6206 C Send the contacts to processors that need them
6207       do ii=1,ntask_cont_to
6208         iproc=itask_cont_to(ii)
6209         nn=ncont_sent(ii)
6210 c        write (iout,*) nn," contacts to processor",iproc,
6211 c     &   " of CONT_TO_COMM group"
6212         if (nn.gt.0) then
6213           ireq=ireq+1
6214           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6215      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6216 c          write (iout,*) "ireq,req",ireq,req(ireq)
6217 c          do i=1,nn
6218 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6219 c          enddo
6220         endif
6221       enddo
6222 c      write (iout,*) "number of requests (contacts)",ireq
6223 c      write (iout,*) "req",(req(i),i=1,4)
6224 c      call flush(iout)
6225       if (ireq.gt.0)
6226      & call MPI_Waitall(ireq,req,status_array,ierr)
6227       do iii=1,ntask_cont_from
6228         iproc=itask_cont_from(iii)
6229         nn=ncont_recv(iii)
6230         if (lprn) then
6231         write (iout,*) "Received",nn," contacts from processor",iproc,
6232      &   " of CONT_FROM_COMM group"
6233         call flush(iout)
6234         do i=1,nn
6235           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6236         enddo
6237         call flush(iout)
6238         endif
6239         do i=1,nn
6240           ii=zapas_recv(1,i,iii)
6241 c Flag the received contacts to prevent double-counting
6242           jj=-zapas_recv(2,i,iii)
6243 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6244 c          call flush(iout)
6245           nnn=num_cont_hb(ii)+1
6246           num_cont_hb(ii)=nnn
6247           jcont_hb(nnn,ii)=jj
6248           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6249           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6250           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6251           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6252           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6253           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6254           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6255           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6256           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6257           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6258           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6259           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6260           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6261           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6262           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6263           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6264           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6265           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6266           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6267           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6268           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6269           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6270           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6271           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6272         enddo
6273       enddo
6274       call flush(iout)
6275       if (lprn) then
6276         write (iout,'(a)') 'Contact function values after receive:'
6277         do i=nnt,nct-2
6278           write (iout,'(2i3,50(1x,i3,f5.2))')
6279      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6280      &    j=1,num_cont_hb(i))
6281         enddo
6282         call flush(iout)
6283       endif
6284    30 continue
6285 #endif
6286       if (lprn) then
6287         write (iout,'(a)') 'Contact function values:'
6288         do i=nnt,nct-2
6289           write (iout,'(2i3,50(1x,i3,f5.2))')
6290      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6291      &    j=1,num_cont_hb(i))
6292         enddo
6293       endif
6294       ecorr=0.0D0
6295 C Remove the loop below after debugging !!!
6296       do i=nnt,nct
6297         do j=1,3
6298           gradcorr(j,i)=0.0D0
6299           gradxorr(j,i)=0.0D0
6300         enddo
6301       enddo
6302 C Calculate the local-electrostatic correlation terms
6303       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6304         i1=i+1
6305         num_conti=num_cont_hb(i)
6306         num_conti1=num_cont_hb(i+1)
6307         do jj=1,num_conti
6308           j=jcont_hb(jj,i)
6309           jp=iabs(j)
6310           do kk=1,num_conti1
6311             j1=jcont_hb(kk,i1)
6312             jp1=iabs(j1)
6313 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6314 c     &         ' jj=',jj,' kk=',kk
6315             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6316      &          .or. j.lt.0 .and. j1.gt.0) .and.
6317      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6318 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6319 C The system gains extra energy.
6320               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6321               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6322      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6323               n_corr=n_corr+1
6324             else if (j1.eq.j) then
6325 C Contacts I-J and I-(J+1) occur simultaneously.
6326 C The system loses extra energy.
6327 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6328             endif
6329           enddo ! kk
6330           do kk=1,num_conti
6331             j1=jcont_hb(kk,i)
6332 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6333 c    &         ' jj=',jj,' kk=',kk
6334             if (j1.eq.j+1) then
6335 C Contacts I-J and (I+1)-J occur simultaneously.
6336 C The system loses extra energy.
6337 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6338             endif ! j1==j+1
6339           enddo ! kk
6340         enddo ! jj
6341       enddo ! i
6342       return
6343       end
6344 c------------------------------------------------------------------------------
6345       subroutine add_hb_contact(ii,jj,itask)
6346       implicit real*8 (a-h,o-z)
6347       include "DIMENSIONS"
6348       include "COMMON.IOUNITS"
6349       integer max_cont
6350       integer max_dim
6351       parameter (max_cont=maxconts)
6352       parameter (max_dim=26)
6353       include "COMMON.CONTACTS"
6354       double precision zapas(max_dim,maxconts,max_fg_procs),
6355      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6356       common /przechowalnia/ zapas
6357       integer i,j,ii,jj,iproc,itask(4),nn
6358 c      write (iout,*) "itask",itask
6359       do i=1,2
6360         iproc=itask(i)
6361         if (iproc.gt.0) then
6362           do j=1,num_cont_hb(ii)
6363             jjc=jcont_hb(j,ii)
6364 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6365             if (jjc.eq.jj) then
6366               ncont_sent(iproc)=ncont_sent(iproc)+1
6367               nn=ncont_sent(iproc)
6368               zapas(1,nn,iproc)=ii
6369               zapas(2,nn,iproc)=jjc
6370               zapas(3,nn,iproc)=facont_hb(j,ii)
6371               zapas(4,nn,iproc)=ees0p(j,ii)
6372               zapas(5,nn,iproc)=ees0m(j,ii)
6373               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6374               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6375               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6376               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6377               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6378               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6379               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6380               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6381               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6382               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6383               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6384               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6385               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6386               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6387               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6388               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6389               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6390               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6391               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6392               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6393               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6394               exit
6395             endif
6396           enddo
6397         endif
6398       enddo
6399       return
6400       end
6401 c------------------------------------------------------------------------------
6402       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6403      &  n_corr1)
6404 C This subroutine calculates multi-body contributions to hydrogen-bonding
6405       implicit real*8 (a-h,o-z)
6406       include 'DIMENSIONS'
6407       include 'COMMON.IOUNITS'
6408 #ifdef MPI
6409       include "mpif.h"
6410       parameter (max_cont=maxconts)
6411       parameter (max_dim=70)
6412       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6413       double precision zapas(max_dim,maxconts,max_fg_procs),
6414      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6415       common /przechowalnia/ zapas
6416       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6417      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6418 #endif
6419       include 'COMMON.SETUP'
6420       include 'COMMON.FFIELD'
6421       include 'COMMON.DERIV'
6422       include 'COMMON.LOCAL'
6423       include 'COMMON.INTERACT'
6424       include 'COMMON.CONTACTS'
6425       include 'COMMON.CHAIN'
6426       include 'COMMON.CONTROL'
6427       double precision gx(3),gx1(3)
6428       integer num_cont_hb_old(maxres)
6429       logical lprn,ldone
6430       double precision eello4,eello5,eelo6,eello_turn6
6431       external eello4,eello5,eello6,eello_turn6
6432 C Set lprn=.true. for debugging
6433       lprn=.false.
6434       eturn6=0.0d0
6435 #ifdef MPI
6436       do i=1,nres
6437         num_cont_hb_old(i)=num_cont_hb(i)
6438       enddo
6439       n_corr=0
6440       n_corr1=0
6441       if (nfgtasks.le.1) goto 30
6442       if (lprn) then
6443         write (iout,'(a)') 'Contact function values before RECEIVE:'
6444         do i=nnt,nct-2
6445           write (iout,'(2i3,50(1x,i2,f5.2))')
6446      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6447      &    j=1,num_cont_hb(i))
6448         enddo
6449       endif
6450       call flush(iout)
6451       do i=1,ntask_cont_from
6452         ncont_recv(i)=0
6453       enddo
6454       do i=1,ntask_cont_to
6455         ncont_sent(i)=0
6456       enddo
6457 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6458 c     & ntask_cont_to
6459 C Make the list of contacts to send to send to other procesors
6460       do i=iturn3_start,iturn3_end
6461 c        write (iout,*) "make contact list turn3",i," num_cont",
6462 c     &    num_cont_hb(i)
6463         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6464       enddo
6465       do i=iturn4_start,iturn4_end
6466 c        write (iout,*) "make contact list turn4",i," num_cont",
6467 c     &   num_cont_hb(i)
6468         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6469       enddo
6470       do ii=1,nat_sent
6471         i=iat_sent(ii)
6472 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6473 c     &    num_cont_hb(i)
6474         do j=1,num_cont_hb(i)
6475         do k=1,4
6476           jjc=jcont_hb(j,i)
6477           iproc=iint_sent_local(k,jjc,ii)
6478 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6479           if (iproc.ne.0) then
6480             ncont_sent(iproc)=ncont_sent(iproc)+1
6481             nn=ncont_sent(iproc)
6482             zapas(1,nn,iproc)=i
6483             zapas(2,nn,iproc)=jjc
6484             zapas(3,nn,iproc)=d_cont(j,i)
6485             ind=3
6486             do kk=1,3
6487               ind=ind+1
6488               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6489             enddo
6490             do kk=1,2
6491               do ll=1,2
6492                 ind=ind+1
6493                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6494               enddo
6495             enddo
6496             do jj=1,5
6497               do kk=1,3
6498                 do ll=1,2
6499                   do mm=1,2
6500                     ind=ind+1
6501                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6502                   enddo
6503                 enddo
6504               enddo
6505             enddo
6506           endif
6507         enddo
6508         enddo
6509       enddo
6510       if (lprn) then
6511       write (iout,*)
6512      &  "Numbers of contacts to be sent to other processors",
6513      &  (ncont_sent(i),i=1,ntask_cont_to)
6514       write (iout,*) "Contacts sent"
6515       do ii=1,ntask_cont_to
6516         nn=ncont_sent(ii)
6517         iproc=itask_cont_to(ii)
6518         write (iout,*) nn," contacts to processor",iproc,
6519      &   " of CONT_TO_COMM group"
6520         do i=1,nn
6521           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6522         enddo
6523       enddo
6524       call flush(iout)
6525       endif
6526       CorrelType=477
6527       CorrelID=fg_rank+1
6528       CorrelType1=478
6529       CorrelID1=nfgtasks+fg_rank+1
6530       ireq=0
6531 C Receive the numbers of needed contacts from other processors
6532       do ii=1,ntask_cont_from
6533         iproc=itask_cont_from(ii)
6534         ireq=ireq+1
6535         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6536      &    FG_COMM,req(ireq),IERR)
6537       enddo
6538 c      write (iout,*) "IRECV ended"
6539 c      call flush(iout)
6540 C Send the number of contacts needed by other processors
6541       do ii=1,ntask_cont_to
6542         iproc=itask_cont_to(ii)
6543         ireq=ireq+1
6544         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6545      &    FG_COMM,req(ireq),IERR)
6546       enddo
6547 c      write (iout,*) "ISEND ended"
6548 c      write (iout,*) "number of requests (nn)",ireq
6549       call flush(iout)
6550       if (ireq.gt.0)
6551      &  call MPI_Waitall(ireq,req,status_array,ierr)
6552 c      write (iout,*)
6553 c     &  "Numbers of contacts to be received from other processors",
6554 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6555 c      call flush(iout)
6556 C Receive contacts
6557       ireq=0
6558       do ii=1,ntask_cont_from
6559         iproc=itask_cont_from(ii)
6560         nn=ncont_recv(ii)
6561 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6562 c     &   " of CONT_TO_COMM group"
6563         call flush(iout)
6564         if (nn.gt.0) then
6565           ireq=ireq+1
6566           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6567      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6568 c          write (iout,*) "ireq,req",ireq,req(ireq)
6569         endif
6570       enddo
6571 C Send the contacts to processors that need them
6572       do ii=1,ntask_cont_to
6573         iproc=itask_cont_to(ii)
6574         nn=ncont_sent(ii)
6575 c        write (iout,*) nn," contacts to processor",iproc,
6576 c     &   " of CONT_TO_COMM group"
6577         if (nn.gt.0) then
6578           ireq=ireq+1
6579           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6580      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6581 c          write (iout,*) "ireq,req",ireq,req(ireq)
6582 c          do i=1,nn
6583 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6584 c          enddo
6585         endif
6586       enddo
6587 c      write (iout,*) "number of requests (contacts)",ireq
6588 c      write (iout,*) "req",(req(i),i=1,4)
6589 c      call flush(iout)
6590       if (ireq.gt.0)
6591      & call MPI_Waitall(ireq,req,status_array,ierr)
6592       do iii=1,ntask_cont_from
6593         iproc=itask_cont_from(iii)
6594         nn=ncont_recv(iii)
6595         if (lprn) then
6596         write (iout,*) "Received",nn," contacts from processor",iproc,
6597      &   " of CONT_FROM_COMM group"
6598         call flush(iout)
6599         do i=1,nn
6600           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6601         enddo
6602         call flush(iout)
6603         endif
6604         do i=1,nn
6605           ii=zapas_recv(1,i,iii)
6606 c Flag the received contacts to prevent double-counting
6607           jj=-zapas_recv(2,i,iii)
6608 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6609 c          call flush(iout)
6610           nnn=num_cont_hb(ii)+1
6611           num_cont_hb(ii)=nnn
6612           jcont_hb(nnn,ii)=jj
6613           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6614           ind=3
6615           do kk=1,3
6616             ind=ind+1
6617             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6618           enddo
6619           do kk=1,2
6620             do ll=1,2
6621               ind=ind+1
6622               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6623             enddo
6624           enddo
6625           do jj=1,5
6626             do kk=1,3
6627               do ll=1,2
6628                 do mm=1,2
6629                   ind=ind+1
6630                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6631                 enddo
6632               enddo
6633             enddo
6634           enddo
6635         enddo
6636       enddo
6637       call flush(iout)
6638       if (lprn) then
6639         write (iout,'(a)') 'Contact function values after receive:'
6640         do i=nnt,nct-2
6641           write (iout,'(2i3,50(1x,i3,5f6.3))')
6642      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6643      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6644         enddo
6645         call flush(iout)
6646       endif
6647    30 continue
6648 #endif
6649       if (lprn) then
6650         write (iout,'(a)') 'Contact function values:'
6651         do i=nnt,nct-2
6652           write (iout,'(2i3,50(1x,i2,5f6.3))')
6653      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6654      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6655         enddo
6656       endif
6657       ecorr=0.0D0
6658       ecorr5=0.0d0
6659       ecorr6=0.0d0
6660 C Remove the loop below after debugging !!!
6661       do i=nnt,nct
6662         do j=1,3
6663           gradcorr(j,i)=0.0D0
6664           gradxorr(j,i)=0.0D0
6665         enddo
6666       enddo
6667 C Calculate the dipole-dipole interaction energies
6668       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6669       do i=iatel_s,iatel_e+1
6670         num_conti=num_cont_hb(i)
6671         do jj=1,num_conti
6672           j=jcont_hb(jj,i)
6673 #ifdef MOMENT
6674           call dipole(i,j,jj)
6675 #endif
6676         enddo
6677       enddo
6678       endif
6679 C Calculate the local-electrostatic correlation terms
6680 c                write (iout,*) "gradcorr5 in eello5 before loop"
6681 c                do iii=1,nres
6682 c                  write (iout,'(i5,3f10.5)')
6683 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6684 c                enddo
6685       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6686 c        write (iout,*) "corr loop i",i
6687         i1=i+1
6688         num_conti=num_cont_hb(i)
6689         num_conti1=num_cont_hb(i+1)
6690         do jj=1,num_conti
6691           j=jcont_hb(jj,i)
6692           jp=iabs(j)
6693           do kk=1,num_conti1
6694             j1=jcont_hb(kk,i1)
6695             jp1=iabs(j1)
6696 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6697 c     &         ' jj=',jj,' kk=',kk
6698 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6699             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6700      &          .or. j.lt.0 .and. j1.gt.0) .and.
6701      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6702 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6703 C The system gains extra energy.
6704               n_corr=n_corr+1
6705               sqd1=dsqrt(d_cont(jj,i))
6706               sqd2=dsqrt(d_cont(kk,i1))
6707               sred_geom = sqd1*sqd2
6708               IF (sred_geom.lt.cutoff_corr) THEN
6709                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6710      &            ekont,fprimcont)
6711 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6712 cd     &         ' jj=',jj,' kk=',kk
6713                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6714                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6715                 do l=1,3
6716                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6717                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6718                 enddo
6719                 n_corr1=n_corr1+1
6720 cd               write (iout,*) 'sred_geom=',sred_geom,
6721 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6722 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6723 cd               write (iout,*) "g_contij",g_contij
6724 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6725 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6726                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6727                 if (wcorr4.gt.0.0d0)
6728      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6729                   if (energy_dec.and.wcorr4.gt.0.0d0)
6730      1                 write (iout,'(a6,4i5,0pf7.3)')
6731      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6732 c                write (iout,*) "gradcorr5 before eello5"
6733 c                do iii=1,nres
6734 c                  write (iout,'(i5,3f10.5)')
6735 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6736 c                enddo
6737                 if (wcorr5.gt.0.0d0)
6738      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6739 c                write (iout,*) "gradcorr5 after eello5"
6740 c                do iii=1,nres
6741 c                  write (iout,'(i5,3f10.5)')
6742 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6743 c                enddo
6744                   if (energy_dec.and.wcorr5.gt.0.0d0)
6745      1                 write (iout,'(a6,4i5,0pf7.3)')
6746      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6747 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6748 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6749                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6750      &               .or. wturn6.eq.0.0d0))then
6751 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6752                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6753                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6754      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6755 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6756 cd     &            'ecorr6=',ecorr6
6757 cd                write (iout,'(4e15.5)') sred_geom,
6758 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6759 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6760 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6761                 else if (wturn6.gt.0.0d0
6762      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6763 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6764                   eturn6=eturn6+eello_turn6(i,jj,kk)
6765                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6766      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6767 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6768                 endif
6769               ENDIF
6770 1111          continue
6771             endif
6772           enddo ! kk
6773         enddo ! jj
6774       enddo ! i
6775       do i=1,nres
6776         num_cont_hb(i)=num_cont_hb_old(i)
6777       enddo
6778 c                write (iout,*) "gradcorr5 in eello5"
6779 c                do iii=1,nres
6780 c                  write (iout,'(i5,3f10.5)')
6781 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6782 c                enddo
6783       return
6784       end
6785 c------------------------------------------------------------------------------
6786       subroutine add_hb_contact_eello(ii,jj,itask)
6787       implicit real*8 (a-h,o-z)
6788       include "DIMENSIONS"
6789       include "COMMON.IOUNITS"
6790       integer max_cont
6791       integer max_dim
6792       parameter (max_cont=maxconts)
6793       parameter (max_dim=70)
6794       include "COMMON.CONTACTS"
6795       double precision zapas(max_dim,maxconts,max_fg_procs),
6796      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6797       common /przechowalnia/ zapas
6798       integer i,j,ii,jj,iproc,itask(4),nn
6799 c      write (iout,*) "itask",itask
6800       do i=1,2
6801         iproc=itask(i)
6802         if (iproc.gt.0) then
6803           do j=1,num_cont_hb(ii)
6804             jjc=jcont_hb(j,ii)
6805 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6806             if (jjc.eq.jj) then
6807               ncont_sent(iproc)=ncont_sent(iproc)+1
6808               nn=ncont_sent(iproc)
6809               zapas(1,nn,iproc)=ii
6810               zapas(2,nn,iproc)=jjc
6811               zapas(3,nn,iproc)=d_cont(j,ii)
6812               ind=3
6813               do kk=1,3
6814                 ind=ind+1
6815                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6816               enddo
6817               do kk=1,2
6818                 do ll=1,2
6819                   ind=ind+1
6820                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6821                 enddo
6822               enddo
6823               do jj=1,5
6824                 do kk=1,3
6825                   do ll=1,2
6826                     do mm=1,2
6827                       ind=ind+1
6828                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6829                     enddo
6830                   enddo
6831                 enddo
6832               enddo
6833               exit
6834             endif
6835           enddo
6836         endif
6837       enddo
6838       return
6839       end
6840 c------------------------------------------------------------------------------
6841       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6842       implicit real*8 (a-h,o-z)
6843       include 'DIMENSIONS'
6844       include 'COMMON.IOUNITS'
6845       include 'COMMON.DERIV'
6846       include 'COMMON.INTERACT'
6847       include 'COMMON.CONTACTS'
6848       double precision gx(3),gx1(3)
6849       logical lprn
6850       lprn=.false.
6851       eij=facont_hb(jj,i)
6852       ekl=facont_hb(kk,k)
6853       ees0pij=ees0p(jj,i)
6854       ees0pkl=ees0p(kk,k)
6855       ees0mij=ees0m(jj,i)
6856       ees0mkl=ees0m(kk,k)
6857       ekont=eij*ekl
6858       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6859 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6860 C Following 4 lines for diagnostics.
6861 cd    ees0pkl=0.0D0
6862 cd    ees0pij=1.0D0
6863 cd    ees0mkl=0.0D0
6864 cd    ees0mij=1.0D0
6865 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6866 c     & 'Contacts ',i,j,
6867 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6868 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6869 c     & 'gradcorr_long'
6870 C Calculate the multi-body contribution to energy.
6871 c      ecorr=ecorr+ekont*ees
6872 C Calculate multi-body contributions to the gradient.
6873       coeffpees0pij=coeffp*ees0pij
6874       coeffmees0mij=coeffm*ees0mij
6875       coeffpees0pkl=coeffp*ees0pkl
6876       coeffmees0mkl=coeffm*ees0mkl
6877       do ll=1,3
6878 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6879         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6880      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6881      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6882         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6883      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6884      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6885 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6886         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6887      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6888      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6889         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6890      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6891      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6892         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6893      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6894      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6895         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6896         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6897         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6898      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6899      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6900         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6901         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6902 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6903       enddo
6904 c      write (iout,*)
6905 cgrad      do m=i+1,j-1
6906 cgrad        do ll=1,3
6907 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6908 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6909 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6910 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6911 cgrad        enddo
6912 cgrad      enddo
6913 cgrad      do m=k+1,l-1
6914 cgrad        do ll=1,3
6915 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6916 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6917 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6918 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6919 cgrad        enddo
6920 cgrad      enddo
6921 c      write (iout,*) "ehbcorr",ekont*ees
6922       ehbcorr=ekont*ees
6923       return
6924       end
6925 #ifdef MOMENT
6926 C---------------------------------------------------------------------------
6927       subroutine dipole(i,j,jj)
6928       implicit real*8 (a-h,o-z)
6929       include 'DIMENSIONS'
6930       include 'COMMON.IOUNITS'
6931       include 'COMMON.CHAIN'
6932       include 'COMMON.FFIELD'
6933       include 'COMMON.DERIV'
6934       include 'COMMON.INTERACT'
6935       include 'COMMON.CONTACTS'
6936       include 'COMMON.TORSION'
6937       include 'COMMON.VAR'
6938       include 'COMMON.GEO'
6939       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6940      &  auxmat(2,2)
6941       iti1 = itortyp(itype(i+1))
6942       if (j.lt.nres-1) then
6943         itj1 = itortyp(itype(j+1))
6944       else
6945         itj1=ntortyp+1
6946       endif
6947       do iii=1,2
6948         dipi(iii,1)=Ub2(iii,i)
6949         dipderi(iii)=Ub2der(iii,i)
6950         dipi(iii,2)=b1(iii,i+1)
6951         dipj(iii,1)=Ub2(iii,j)
6952         dipderj(iii)=Ub2der(iii,j)
6953         dipj(iii,2)=b1(iii,j+1)
6954       enddo
6955       kkk=0
6956       do iii=1,2
6957         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6958         do jjj=1,2
6959           kkk=kkk+1
6960           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6961         enddo
6962       enddo
6963       do kkk=1,5
6964         do lll=1,3
6965           mmm=0
6966           do iii=1,2
6967             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6968      &        auxvec(1))
6969             do jjj=1,2
6970               mmm=mmm+1
6971               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6972             enddo
6973           enddo
6974         enddo
6975       enddo
6976       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6977       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6978       do iii=1,2
6979         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6980       enddo
6981       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6982       do iii=1,2
6983         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6984       enddo
6985       return
6986       end
6987 #endif
6988 C---------------------------------------------------------------------------
6989       subroutine calc_eello(i,j,k,l,jj,kk)
6990 C
6991 C This subroutine computes matrices and vectors needed to calculate
6992 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6993 C
6994       implicit real*8 (a-h,o-z)
6995       include 'DIMENSIONS'
6996       include 'COMMON.IOUNITS'
6997       include 'COMMON.CHAIN'
6998       include 'COMMON.DERIV'
6999       include 'COMMON.INTERACT'
7000       include 'COMMON.CONTACTS'
7001       include 'COMMON.TORSION'
7002       include 'COMMON.VAR'
7003       include 'COMMON.GEO'
7004       include 'COMMON.FFIELD'
7005       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7006      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7007       logical lprn
7008       common /kutas/ lprn
7009 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7010 cd     & ' jj=',jj,' kk=',kk
7011 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7012 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7013 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7014       do iii=1,2
7015         do jjj=1,2
7016           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7017           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7018         enddo
7019       enddo
7020       call transpose2(aa1(1,1),aa1t(1,1))
7021       call transpose2(aa2(1,1),aa2t(1,1))
7022       do kkk=1,5
7023         do lll=1,3
7024           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7025      &      aa1tder(1,1,lll,kkk))
7026           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7027      &      aa2tder(1,1,lll,kkk))
7028         enddo
7029       enddo
7030       if (l.eq.j+1) then
7031 C parallel orientation of the two CA-CA-CA frames.
7032         if (i.gt.1) then
7033           iti=itortyp(itype(i))
7034         else
7035           iti=ntortyp+1
7036         endif
7037         itk1=itortyp(itype(k+1))
7038         itj=itortyp(itype(j))
7039         if (l.lt.nres-1) then
7040           itl1=itortyp(itype(l+1))
7041         else
7042           itl1=ntortyp+1
7043         endif
7044 C A1 kernel(j+1) A2T
7045 cd        do iii=1,2
7046 cd          write (iout,'(3f10.5,5x,3f10.5)')
7047 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7048 cd        enddo
7049         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7050      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7051      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7052 C Following matrices are needed only for 6-th order cumulants
7053         IF (wcorr6.gt.0.0d0) THEN
7054         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7055      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7056      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7057         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7058      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7059      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7060      &   ADtEAderx(1,1,1,1,1,1))
7061         lprn=.false.
7062         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7063      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7064      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7065      &   ADtEA1derx(1,1,1,1,1,1))
7066         ENDIF
7067 C End 6-th order cumulants
7068 cd        lprn=.false.
7069 cd        if (lprn) then
7070 cd        write (2,*) 'In calc_eello6'
7071 cd        do iii=1,2
7072 cd          write (2,*) 'iii=',iii
7073 cd          do kkk=1,5
7074 cd            write (2,*) 'kkk=',kkk
7075 cd            do jjj=1,2
7076 cd              write (2,'(3(2f10.5),5x)')
7077 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7078 cd            enddo
7079 cd          enddo
7080 cd        enddo
7081 cd        endif
7082         call transpose2(EUgder(1,1,k),auxmat(1,1))
7083         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7084         call transpose2(EUg(1,1,k),auxmat(1,1))
7085         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7086         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7087         do iii=1,2
7088           do kkk=1,5
7089             do lll=1,3
7090               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7091      &          EAEAderx(1,1,lll,kkk,iii,1))
7092             enddo
7093           enddo
7094         enddo
7095 C A1T kernel(i+1) A2
7096         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7097      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7098      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7099 C Following matrices are needed only for 6-th order cumulants
7100         IF (wcorr6.gt.0.0d0) THEN
7101         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7102      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7103      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7104         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7105      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7106      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7107      &   ADtEAderx(1,1,1,1,1,2))
7108         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7109      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7110      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7111      &   ADtEA1derx(1,1,1,1,1,2))
7112         ENDIF
7113 C End 6-th order cumulants
7114         call transpose2(EUgder(1,1,l),auxmat(1,1))
7115         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7116         call transpose2(EUg(1,1,l),auxmat(1,1))
7117         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7118         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7119         do iii=1,2
7120           do kkk=1,5
7121             do lll=1,3
7122               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7123      &          EAEAderx(1,1,lll,kkk,iii,2))
7124             enddo
7125           enddo
7126         enddo
7127 C AEAb1 and AEAb2
7128 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7129 C They are needed only when the fifth- or the sixth-order cumulants are
7130 C indluded.
7131         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7132         call transpose2(AEA(1,1,1),auxmat(1,1))
7133         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7134         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7135         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7136         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7137         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7138         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7139         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7140         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7141         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7142         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7143         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7144         call transpose2(AEA(1,1,2),auxmat(1,1))
7145         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7146         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7147         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7148         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7149         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7150         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7151         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7152         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7153         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7154         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7155         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7156 C Calculate the Cartesian derivatives of the vectors.
7157         do iii=1,2
7158           do kkk=1,5
7159             do lll=1,3
7160               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7161               call matvec2(auxmat(1,1),b1(1,i),
7162      &          AEAb1derx(1,lll,kkk,iii,1,1))
7163               call matvec2(auxmat(1,1),Ub2(1,i),
7164      &          AEAb2derx(1,lll,kkk,iii,1,1))
7165               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7166      &          AEAb1derx(1,lll,kkk,iii,2,1))
7167               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7168      &          AEAb2derx(1,lll,kkk,iii,2,1))
7169               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7170               call matvec2(auxmat(1,1),b1(1,j),
7171      &          AEAb1derx(1,lll,kkk,iii,1,2))
7172               call matvec2(auxmat(1,1),Ub2(1,j),
7173      &          AEAb2derx(1,lll,kkk,iii,1,2))
7174               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7175      &          AEAb1derx(1,lll,kkk,iii,2,2))
7176               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7177      &          AEAb2derx(1,lll,kkk,iii,2,2))
7178             enddo
7179           enddo
7180         enddo
7181         ENDIF
7182 C End vectors
7183       else
7184 C Antiparallel orientation of the two CA-CA-CA frames.
7185         if (i.gt.1) then
7186           iti=itortyp(itype(i))
7187         else
7188           iti=ntortyp+1
7189         endif
7190         itk1=itortyp(itype(k+1))
7191         itl=itortyp(itype(l))
7192         itj=itortyp(itype(j))
7193         if (j.lt.nres-1) then
7194           itj1=itortyp(itype(j+1))
7195         else
7196           itj1=ntortyp+1
7197         endif
7198 C A2 kernel(j-1)T A1T
7199         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7200      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7201      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7202 C Following matrices are needed only for 6-th order cumulants
7203         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7204      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7205         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7206      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7207      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7208         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7209      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7210      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7211      &   ADtEAderx(1,1,1,1,1,1))
7212         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7213      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7214      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7215      &   ADtEA1derx(1,1,1,1,1,1))
7216         ENDIF
7217 C End 6-th order cumulants
7218         call transpose2(EUgder(1,1,k),auxmat(1,1))
7219         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7220         call transpose2(EUg(1,1,k),auxmat(1,1))
7221         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7222         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7223         do iii=1,2
7224           do kkk=1,5
7225             do lll=1,3
7226               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7227      &          EAEAderx(1,1,lll,kkk,iii,1))
7228             enddo
7229           enddo
7230         enddo
7231 C A2T kernel(i+1)T A1
7232         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7233      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7234      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7235 C Following matrices are needed only for 6-th order cumulants
7236         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7237      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7238         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7239      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7240      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7241         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7242      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7243      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7244      &   ADtEAderx(1,1,1,1,1,2))
7245         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7246      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7247      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7248      &   ADtEA1derx(1,1,1,1,1,2))
7249         ENDIF
7250 C End 6-th order cumulants
7251         call transpose2(EUgder(1,1,j),auxmat(1,1))
7252         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7253         call transpose2(EUg(1,1,j),auxmat(1,1))
7254         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7255         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7256         do iii=1,2
7257           do kkk=1,5
7258             do lll=1,3
7259               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7260      &          EAEAderx(1,1,lll,kkk,iii,2))
7261             enddo
7262           enddo
7263         enddo
7264 C AEAb1 and AEAb2
7265 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7266 C They are needed only when the fifth- or the sixth-order cumulants are
7267 C indluded.
7268         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7269      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7270         call transpose2(AEA(1,1,1),auxmat(1,1))
7271         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7272         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7273         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7274         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7275         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7276         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7277         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7278         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7279         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7280         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7281         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7282         call transpose2(AEA(1,1,2),auxmat(1,1))
7283         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7284         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7285         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7286         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7287         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7288         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7289         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7290         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7291         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7292         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7293         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7294 C Calculate the Cartesian derivatives of the vectors.
7295         do iii=1,2
7296           do kkk=1,5
7297             do lll=1,3
7298               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7299               call matvec2(auxmat(1,1),b1(1,i),
7300      &          AEAb1derx(1,lll,kkk,iii,1,1))
7301               call matvec2(auxmat(1,1),Ub2(1,i),
7302      &          AEAb2derx(1,lll,kkk,iii,1,1))
7303               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7304      &          AEAb1derx(1,lll,kkk,iii,2,1))
7305               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7306      &          AEAb2derx(1,lll,kkk,iii,2,1))
7307               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7308               call matvec2(auxmat(1,1),b1(1,l),
7309      &          AEAb1derx(1,lll,kkk,iii,1,2))
7310               call matvec2(auxmat(1,1),Ub2(1,l),
7311      &          AEAb2derx(1,lll,kkk,iii,1,2))
7312               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7313      &          AEAb1derx(1,lll,kkk,iii,2,2))
7314               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7315      &          AEAb2derx(1,lll,kkk,iii,2,2))
7316             enddo
7317           enddo
7318         enddo
7319         ENDIF
7320 C End vectors
7321       endif
7322       return
7323       end
7324 C---------------------------------------------------------------------------
7325       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7326      &  KK,KKderg,AKA,AKAderg,AKAderx)
7327       implicit none
7328       integer nderg
7329       logical transp
7330       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7331      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7332      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7333       integer iii,kkk,lll
7334       integer jjj,mmm
7335       logical lprn
7336       common /kutas/ lprn
7337       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7338       do iii=1,nderg
7339         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7340      &    AKAderg(1,1,iii))
7341       enddo
7342 cd      if (lprn) write (2,*) 'In kernel'
7343       do kkk=1,5
7344 cd        if (lprn) write (2,*) 'kkk=',kkk
7345         do lll=1,3
7346           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7347      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7348 cd          if (lprn) then
7349 cd            write (2,*) 'lll=',lll
7350 cd            write (2,*) 'iii=1'
7351 cd            do jjj=1,2
7352 cd              write (2,'(3(2f10.5),5x)')
7353 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7354 cd            enddo
7355 cd          endif
7356           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7357      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7358 cd          if (lprn) then
7359 cd            write (2,*) 'lll=',lll
7360 cd            write (2,*) 'iii=2'
7361 cd            do jjj=1,2
7362 cd              write (2,'(3(2f10.5),5x)')
7363 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7364 cd            enddo
7365 cd          endif
7366         enddo
7367       enddo
7368       return
7369       end
7370 C---------------------------------------------------------------------------
7371       double precision function eello4(i,j,k,l,jj,kk)
7372       implicit real*8 (a-h,o-z)
7373       include 'DIMENSIONS'
7374       include 'COMMON.IOUNITS'
7375       include 'COMMON.CHAIN'
7376       include 'COMMON.DERIV'
7377       include 'COMMON.INTERACT'
7378       include 'COMMON.CONTACTS'
7379       include 'COMMON.TORSION'
7380       include 'COMMON.VAR'
7381       include 'COMMON.GEO'
7382       double precision pizda(2,2),ggg1(3),ggg2(3)
7383 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7384 cd        eello4=0.0d0
7385 cd        return
7386 cd      endif
7387 cd      print *,'eello4:',i,j,k,l,jj,kk
7388 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7389 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7390 cold      eij=facont_hb(jj,i)
7391 cold      ekl=facont_hb(kk,k)
7392 cold      ekont=eij*ekl
7393       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7394 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7395       gcorr_loc(k-1)=gcorr_loc(k-1)
7396      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7397       if (l.eq.j+1) then
7398         gcorr_loc(l-1)=gcorr_loc(l-1)
7399      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7400       else
7401         gcorr_loc(j-1)=gcorr_loc(j-1)
7402      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7403       endif
7404       do iii=1,2
7405         do kkk=1,5
7406           do lll=1,3
7407             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7408      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7409 cd            derx(lll,kkk,iii)=0.0d0
7410           enddo
7411         enddo
7412       enddo
7413 cd      gcorr_loc(l-1)=0.0d0
7414 cd      gcorr_loc(j-1)=0.0d0
7415 cd      gcorr_loc(k-1)=0.0d0
7416 cd      eel4=1.0d0
7417 cd      write (iout,*)'Contacts have occurred for peptide groups',
7418 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7419 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7420       if (j.lt.nres-1) then
7421         j1=j+1
7422         j2=j-1
7423       else
7424         j1=j-1
7425         j2=j-2
7426       endif
7427       if (l.lt.nres-1) then
7428         l1=l+1
7429         l2=l-1
7430       else
7431         l1=l-1
7432         l2=l-2
7433       endif
7434       do ll=1,3
7435 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7436 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7437         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7438         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7439 cgrad        ghalf=0.5d0*ggg1(ll)
7440         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7441         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7442         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7443         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7444         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7445         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7446 cgrad        ghalf=0.5d0*ggg2(ll)
7447         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7448         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7449         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7450         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7451         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7452         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7453       enddo
7454 cgrad      do m=i+1,j-1
7455 cgrad        do ll=1,3
7456 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7457 cgrad        enddo
7458 cgrad      enddo
7459 cgrad      do m=k+1,l-1
7460 cgrad        do ll=1,3
7461 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7462 cgrad        enddo
7463 cgrad      enddo
7464 cgrad      do m=i+2,j2
7465 cgrad        do ll=1,3
7466 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7467 cgrad        enddo
7468 cgrad      enddo
7469 cgrad      do m=k+2,l2
7470 cgrad        do ll=1,3
7471 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7472 cgrad        enddo
7473 cgrad      enddo
7474 cd      do iii=1,nres-3
7475 cd        write (2,*) iii,gcorr_loc(iii)
7476 cd      enddo
7477       eello4=ekont*eel4
7478 cd      write (2,*) 'ekont',ekont
7479 cd      write (iout,*) 'eello4',ekont*eel4
7480       return
7481       end
7482 C---------------------------------------------------------------------------
7483       double precision function eello5(i,j,k,l,jj,kk)
7484       implicit real*8 (a-h,o-z)
7485       include 'DIMENSIONS'
7486       include 'COMMON.IOUNITS'
7487       include 'COMMON.CHAIN'
7488       include 'COMMON.DERIV'
7489       include 'COMMON.INTERACT'
7490       include 'COMMON.CONTACTS'
7491       include 'COMMON.TORSION'
7492       include 'COMMON.VAR'
7493       include 'COMMON.GEO'
7494       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7495       double precision ggg1(3),ggg2(3)
7496 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7497 C                                                                              C
7498 C                            Parallel chains                                   C
7499 C                                                                              C
7500 C          o             o                   o             o                   C
7501 C         /l\           / \             \   / \           / \   /              C
7502 C        /   \         /   \             \ /   \         /   \ /               C
7503 C       j| o |l1       | o |              o| o |         | o |o                C
7504 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7505 C      \i/   \         /   \ /             /   \         /   \                 C
7506 C       o    k1             o                                                  C
7507 C         (I)          (II)                (III)          (IV)                 C
7508 C                                                                              C
7509 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7510 C                                                                              C
7511 C                            Antiparallel chains                               C
7512 C                                                                              C
7513 C          o             o                   o             o                   C
7514 C         /j\           / \             \   / \           / \   /              C
7515 C        /   \         /   \             \ /   \         /   \ /               C
7516 C      j1| o |l        | o |              o| o |         | o |o                C
7517 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7518 C      \i/   \         /   \ /             /   \         /   \                 C
7519 C       o     k1            o                                                  C
7520 C         (I)          (II)                (III)          (IV)                 C
7521 C                                                                              C
7522 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7523 C                                                                              C
7524 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7525 C                                                                              C
7526 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7527 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7528 cd        eello5=0.0d0
7529 cd        return
7530 cd      endif
7531 cd      write (iout,*)
7532 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7533 cd     &   ' and',k,l
7534       itk=itortyp(itype(k))
7535       itl=itortyp(itype(l))
7536       itj=itortyp(itype(j))
7537       eello5_1=0.0d0
7538       eello5_2=0.0d0
7539       eello5_3=0.0d0
7540       eello5_4=0.0d0
7541 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7542 cd     &   eel5_3_num,eel5_4_num)
7543       do iii=1,2
7544         do kkk=1,5
7545           do lll=1,3
7546             derx(lll,kkk,iii)=0.0d0
7547           enddo
7548         enddo
7549       enddo
7550 cd      eij=facont_hb(jj,i)
7551 cd      ekl=facont_hb(kk,k)
7552 cd      ekont=eij*ekl
7553 cd      write (iout,*)'Contacts have occurred for peptide groups',
7554 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7555 cd      goto 1111
7556 C Contribution from the graph I.
7557 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7558 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7559       call transpose2(EUg(1,1,k),auxmat(1,1))
7560       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7561       vv(1)=pizda(1,1)-pizda(2,2)
7562       vv(2)=pizda(1,2)+pizda(2,1)
7563       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7564      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7565 C Explicit gradient in virtual-dihedral angles.
7566       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7567      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7568      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7569       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7570       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7571       vv(1)=pizda(1,1)-pizda(2,2)
7572       vv(2)=pizda(1,2)+pizda(2,1)
7573       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7574      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7575      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7576       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7577       vv(1)=pizda(1,1)-pizda(2,2)
7578       vv(2)=pizda(1,2)+pizda(2,1)
7579       if (l.eq.j+1) then
7580         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7581      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7582      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7583       else
7584         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7585      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7586      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7587       endif
7588 C Cartesian gradient
7589       do iii=1,2
7590         do kkk=1,5
7591           do lll=1,3
7592             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7593      &        pizda(1,1))
7594             vv(1)=pizda(1,1)-pizda(2,2)
7595             vv(2)=pizda(1,2)+pizda(2,1)
7596             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7597      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7598      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7599           enddo
7600         enddo
7601       enddo
7602 c      goto 1112
7603 c1111  continue
7604 C Contribution from graph II
7605       call transpose2(EE(1,1,itk),auxmat(1,1))
7606       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7607       vv(1)=pizda(1,1)+pizda(2,2)
7608       vv(2)=pizda(2,1)-pizda(1,2)
7609       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7610      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7611 C Explicit gradient in virtual-dihedral angles.
7612       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7613      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7614       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7615       vv(1)=pizda(1,1)+pizda(2,2)
7616       vv(2)=pizda(2,1)-pizda(1,2)
7617       if (l.eq.j+1) then
7618         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7619      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7620      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7621       else
7622         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7623      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7624      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7625       endif
7626 C Cartesian gradient
7627       do iii=1,2
7628         do kkk=1,5
7629           do lll=1,3
7630             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7631      &        pizda(1,1))
7632             vv(1)=pizda(1,1)+pizda(2,2)
7633             vv(2)=pizda(2,1)-pizda(1,2)
7634             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7635      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7636      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7637           enddo
7638         enddo
7639       enddo
7640 cd      goto 1112
7641 cd1111  continue
7642       if (l.eq.j+1) then
7643 cd        goto 1110
7644 C Parallel orientation
7645 C Contribution from graph III
7646         call transpose2(EUg(1,1,l),auxmat(1,1))
7647         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7648         vv(1)=pizda(1,1)-pizda(2,2)
7649         vv(2)=pizda(1,2)+pizda(2,1)
7650         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7651      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7652 C Explicit gradient in virtual-dihedral angles.
7653         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7654      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7655      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7656         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7657         vv(1)=pizda(1,1)-pizda(2,2)
7658         vv(2)=pizda(1,2)+pizda(2,1)
7659         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7660      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7661      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7662         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7663         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7664         vv(1)=pizda(1,1)-pizda(2,2)
7665         vv(2)=pizda(1,2)+pizda(2,1)
7666         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7667      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7668      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7669 C Cartesian gradient
7670         do iii=1,2
7671           do kkk=1,5
7672             do lll=1,3
7673               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7674      &          pizda(1,1))
7675               vv(1)=pizda(1,1)-pizda(2,2)
7676               vv(2)=pizda(1,2)+pizda(2,1)
7677               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7678      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7679      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7680             enddo
7681           enddo
7682         enddo
7683 cd        goto 1112
7684 C Contribution from graph IV
7685 cd1110    continue
7686         call transpose2(EE(1,1,itl),auxmat(1,1))
7687         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7688         vv(1)=pizda(1,1)+pizda(2,2)
7689         vv(2)=pizda(2,1)-pizda(1,2)
7690         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7691      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7692 C Explicit gradient in virtual-dihedral angles.
7693         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7694      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7695         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7696         vv(1)=pizda(1,1)+pizda(2,2)
7697         vv(2)=pizda(2,1)-pizda(1,2)
7698         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7699      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7700      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7701 C Cartesian gradient
7702         do iii=1,2
7703           do kkk=1,5
7704             do lll=1,3
7705               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7706      &          pizda(1,1))
7707               vv(1)=pizda(1,1)+pizda(2,2)
7708               vv(2)=pizda(2,1)-pizda(1,2)
7709               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7710      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7711      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7712             enddo
7713           enddo
7714         enddo
7715       else
7716 C Antiparallel orientation
7717 C Contribution from graph III
7718 c        goto 1110
7719         call transpose2(EUg(1,1,j),auxmat(1,1))
7720         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7721         vv(1)=pizda(1,1)-pizda(2,2)
7722         vv(2)=pizda(1,2)+pizda(2,1)
7723         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7724      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7725 C Explicit gradient in virtual-dihedral angles.
7726         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7727      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7728      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7729         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7730         vv(1)=pizda(1,1)-pizda(2,2)
7731         vv(2)=pizda(1,2)+pizda(2,1)
7732         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7733      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7734      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7735         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7736         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7737         vv(1)=pizda(1,1)-pizda(2,2)
7738         vv(2)=pizda(1,2)+pizda(2,1)
7739         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7740      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7741      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7742 C Cartesian gradient
7743         do iii=1,2
7744           do kkk=1,5
7745             do lll=1,3
7746               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7747      &          pizda(1,1))
7748               vv(1)=pizda(1,1)-pizda(2,2)
7749               vv(2)=pizda(1,2)+pizda(2,1)
7750               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7751      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7752      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7753             enddo
7754           enddo
7755         enddo
7756 cd        goto 1112
7757 C Contribution from graph IV
7758 1110    continue
7759         call transpose2(EE(1,1,itj),auxmat(1,1))
7760         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7761         vv(1)=pizda(1,1)+pizda(2,2)
7762         vv(2)=pizda(2,1)-pizda(1,2)
7763         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7764      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7765 C Explicit gradient in virtual-dihedral angles.
7766         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7767      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7768         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7769         vv(1)=pizda(1,1)+pizda(2,2)
7770         vv(2)=pizda(2,1)-pizda(1,2)
7771         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7772      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7773      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7774 C Cartesian gradient
7775         do iii=1,2
7776           do kkk=1,5
7777             do lll=1,3
7778               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7779      &          pizda(1,1))
7780               vv(1)=pizda(1,1)+pizda(2,2)
7781               vv(2)=pizda(2,1)-pizda(1,2)
7782               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7783      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7784      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7785             enddo
7786           enddo
7787         enddo
7788       endif
7789 1112  continue
7790       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7791 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7792 cd        write (2,*) 'ijkl',i,j,k,l
7793 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7794 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7795 cd      endif
7796 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7797 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7798 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7799 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7800       if (j.lt.nres-1) then
7801         j1=j+1
7802         j2=j-1
7803       else
7804         j1=j-1
7805         j2=j-2
7806       endif
7807       if (l.lt.nres-1) then
7808         l1=l+1
7809         l2=l-1
7810       else
7811         l1=l-1
7812         l2=l-2
7813       endif
7814 cd      eij=1.0d0
7815 cd      ekl=1.0d0
7816 cd      ekont=1.0d0
7817 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7818 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7819 C        summed up outside the subrouine as for the other subroutines
7820 C        handling long-range interactions. The old code is commented out
7821 C        with "cgrad" to keep track of changes.
7822       do ll=1,3
7823 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7824 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7825         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7826         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7827 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7828 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7829 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7830 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7831 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7832 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7833 c     &   gradcorr5ij,
7834 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7835 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7836 cgrad        ghalf=0.5d0*ggg1(ll)
7837 cd        ghalf=0.0d0
7838         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7839         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7840         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7841         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7842         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7843         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7844 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7845 cgrad        ghalf=0.5d0*ggg2(ll)
7846 cd        ghalf=0.0d0
7847         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7848         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7849         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7850         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7851         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7852         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7853       enddo
7854 cd      goto 1112
7855 cgrad      do m=i+1,j-1
7856 cgrad        do ll=1,3
7857 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7858 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7859 cgrad        enddo
7860 cgrad      enddo
7861 cgrad      do m=k+1,l-1
7862 cgrad        do ll=1,3
7863 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7864 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7865 cgrad        enddo
7866 cgrad      enddo
7867 c1112  continue
7868 cgrad      do m=i+2,j2
7869 cgrad        do ll=1,3
7870 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7871 cgrad        enddo
7872 cgrad      enddo
7873 cgrad      do m=k+2,l2
7874 cgrad        do ll=1,3
7875 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7876 cgrad        enddo
7877 cgrad      enddo
7878 cd      do iii=1,nres-3
7879 cd        write (2,*) iii,g_corr5_loc(iii)
7880 cd      enddo
7881       eello5=ekont*eel5
7882 cd      write (2,*) 'ekont',ekont
7883 cd      write (iout,*) 'eello5',ekont*eel5
7884       return
7885       end
7886 c--------------------------------------------------------------------------
7887       double precision function eello6(i,j,k,l,jj,kk)
7888       implicit real*8 (a-h,o-z)
7889       include 'DIMENSIONS'
7890       include 'COMMON.IOUNITS'
7891       include 'COMMON.CHAIN'
7892       include 'COMMON.DERIV'
7893       include 'COMMON.INTERACT'
7894       include 'COMMON.CONTACTS'
7895       include 'COMMON.TORSION'
7896       include 'COMMON.VAR'
7897       include 'COMMON.GEO'
7898       include 'COMMON.FFIELD'
7899       double precision ggg1(3),ggg2(3)
7900 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7901 cd        eello6=0.0d0
7902 cd        return
7903 cd      endif
7904 cd      write (iout,*)
7905 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7906 cd     &   ' and',k,l
7907       eello6_1=0.0d0
7908       eello6_2=0.0d0
7909       eello6_3=0.0d0
7910       eello6_4=0.0d0
7911       eello6_5=0.0d0
7912       eello6_6=0.0d0
7913 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7914 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7915       do iii=1,2
7916         do kkk=1,5
7917           do lll=1,3
7918             derx(lll,kkk,iii)=0.0d0
7919           enddo
7920         enddo
7921       enddo
7922 cd      eij=facont_hb(jj,i)
7923 cd      ekl=facont_hb(kk,k)
7924 cd      ekont=eij*ekl
7925 cd      eij=1.0d0
7926 cd      ekl=1.0d0
7927 cd      ekont=1.0d0
7928       if (l.eq.j+1) then
7929         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7930         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7931         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7932         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7933         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7934         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7935       else
7936         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7937         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7938         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7939         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7940         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7941           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7942         else
7943           eello6_5=0.0d0
7944         endif
7945         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7946       endif
7947 C If turn contributions are considered, they will be handled separately.
7948       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7949 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7950 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7951 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7952 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7953 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7954 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7955 cd      goto 1112
7956       if (j.lt.nres-1) then
7957         j1=j+1
7958         j2=j-1
7959       else
7960         j1=j-1
7961         j2=j-2
7962       endif
7963       if (l.lt.nres-1) then
7964         l1=l+1
7965         l2=l-1
7966       else
7967         l1=l-1
7968         l2=l-2
7969       endif
7970       do ll=1,3
7971 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7972 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7973 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7974 cgrad        ghalf=0.5d0*ggg1(ll)
7975 cd        ghalf=0.0d0
7976         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7977         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7978         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7979         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7980         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7981         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7982         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7983         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7984 cgrad        ghalf=0.5d0*ggg2(ll)
7985 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7986 cd        ghalf=0.0d0
7987         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7988         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7989         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7990         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7991         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7992         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7993       enddo
7994 cd      goto 1112
7995 cgrad      do m=i+1,j-1
7996 cgrad        do ll=1,3
7997 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7998 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7999 cgrad        enddo
8000 cgrad      enddo
8001 cgrad      do m=k+1,l-1
8002 cgrad        do ll=1,3
8003 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8004 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8005 cgrad        enddo
8006 cgrad      enddo
8007 cgrad1112  continue
8008 cgrad      do m=i+2,j2
8009 cgrad        do ll=1,3
8010 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8011 cgrad        enddo
8012 cgrad      enddo
8013 cgrad      do m=k+2,l2
8014 cgrad        do ll=1,3
8015 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8016 cgrad        enddo
8017 cgrad      enddo
8018 cd      do iii=1,nres-3
8019 cd        write (2,*) iii,g_corr6_loc(iii)
8020 cd      enddo
8021       eello6=ekont*eel6
8022 cd      write (2,*) 'ekont',ekont
8023 cd      write (iout,*) 'eello6',ekont*eel6
8024       return
8025       end
8026 c--------------------------------------------------------------------------
8027       double precision function eello6_graph1(i,j,k,l,imat,swap)
8028       implicit real*8 (a-h,o-z)
8029       include 'DIMENSIONS'
8030       include 'COMMON.IOUNITS'
8031       include 'COMMON.CHAIN'
8032       include 'COMMON.DERIV'
8033       include 'COMMON.INTERACT'
8034       include 'COMMON.CONTACTS'
8035       include 'COMMON.TORSION'
8036       include 'COMMON.VAR'
8037       include 'COMMON.GEO'
8038       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8039       logical swap
8040       logical lprn
8041       common /kutas/ lprn
8042 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8043 C                                                                              C
8044 C      Parallel       Antiparallel                                             C
8045 C                                                                              C
8046 C          o             o                                                     C
8047 C         /l\           /j\                                                    C
8048 C        /   \         /   \                                                   C
8049 C       /| o |         | o |\                                                  C
8050 C     \ j|/k\|  /   \  |/k\|l /                                                C
8051 C      \ /   \ /     \ /   \ /                                                 C
8052 C       o     o       o     o                                                  C
8053 C       i             i                                                        C
8054 C                                                                              C
8055 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8056       itk=itortyp(itype(k))
8057       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8058       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8059       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8060       call transpose2(EUgC(1,1,k),auxmat(1,1))
8061       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8062       vv1(1)=pizda1(1,1)-pizda1(2,2)
8063       vv1(2)=pizda1(1,2)+pizda1(2,1)
8064       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8065       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8066       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8067       s5=scalar2(vv(1),Dtobr2(1,i))
8068 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8069       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8070       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8071      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8072      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8073      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8074      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8075      & +scalar2(vv(1),Dtobr2der(1,i)))
8076       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8077       vv1(1)=pizda1(1,1)-pizda1(2,2)
8078       vv1(2)=pizda1(1,2)+pizda1(2,1)
8079       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8080       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8081       if (l.eq.j+1) then
8082         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8083      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8084      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8085      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8086      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8087       else
8088         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8089      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8090      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8091      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8092      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8093       endif
8094       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8095       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8096       vv1(1)=pizda1(1,1)-pizda1(2,2)
8097       vv1(2)=pizda1(1,2)+pizda1(2,1)
8098       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8099      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8100      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8101      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8102       do iii=1,2
8103         if (swap) then
8104           ind=3-iii
8105         else
8106           ind=iii
8107         endif
8108         do kkk=1,5
8109           do lll=1,3
8110             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8111             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8112             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8113             call transpose2(EUgC(1,1,k),auxmat(1,1))
8114             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8115      &        pizda1(1,1))
8116             vv1(1)=pizda1(1,1)-pizda1(2,2)
8117             vv1(2)=pizda1(1,2)+pizda1(2,1)
8118             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8119             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8120      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8121             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8122      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8123             s5=scalar2(vv(1),Dtobr2(1,i))
8124             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8125           enddo
8126         enddo
8127       enddo
8128       return
8129       end
8130 c----------------------------------------------------------------------------
8131       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8132       implicit real*8 (a-h,o-z)
8133       include 'DIMENSIONS'
8134       include 'COMMON.IOUNITS'
8135       include 'COMMON.CHAIN'
8136       include 'COMMON.DERIV'
8137       include 'COMMON.INTERACT'
8138       include 'COMMON.CONTACTS'
8139       include 'COMMON.TORSION'
8140       include 'COMMON.VAR'
8141       include 'COMMON.GEO'
8142       logical swap
8143       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8144      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8145       logical lprn
8146       common /kutas/ lprn
8147 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8148 C                                                                              C
8149 C      Parallel       Antiparallel                                             C
8150 C                                                                              C
8151 C          o             o                                                     C
8152 C     \   /l\           /j\   /                                                C
8153 C      \ /   \         /   \ /                                                 C
8154 C       o| o |         | o |o                                                  C
8155 C     \ j|/k\|      \  |/k\|l                                                  C
8156 C      \ /   \       \ /   \                                                   C
8157 C       o             o                                                        C
8158 C       i             i                                                        C
8159 C                                                                              C
8160 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8161 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8162 C AL 7/4/01 s1 would occur in the sixth-order moment,
8163 C           but not in a cluster cumulant
8164 #ifdef MOMENT
8165       s1=dip(1,jj,i)*dip(1,kk,k)
8166 #endif
8167       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8168       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8169       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8170       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8171       call transpose2(EUg(1,1,k),auxmat(1,1))
8172       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8173       vv(1)=pizda(1,1)-pizda(2,2)
8174       vv(2)=pizda(1,2)+pizda(2,1)
8175       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8176 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8177 #ifdef MOMENT
8178       eello6_graph2=-(s1+s2+s3+s4)
8179 #else
8180       eello6_graph2=-(s2+s3+s4)
8181 #endif
8182 c      eello6_graph2=-s3
8183 C Derivatives in gamma(i-1)
8184       if (i.gt.1) then
8185 #ifdef MOMENT
8186         s1=dipderg(1,jj,i)*dip(1,kk,k)
8187 #endif
8188         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8189         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8190         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8191         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8192 #ifdef MOMENT
8193         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8194 #else
8195         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8196 #endif
8197 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8198       endif
8199 C Derivatives in gamma(k-1)
8200 #ifdef MOMENT
8201       s1=dip(1,jj,i)*dipderg(1,kk,k)
8202 #endif
8203       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8204       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8205       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8206       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8207       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8208       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8209       vv(1)=pizda(1,1)-pizda(2,2)
8210       vv(2)=pizda(1,2)+pizda(2,1)
8211       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8212 #ifdef MOMENT
8213       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8214 #else
8215       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8216 #endif
8217 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8218 C Derivatives in gamma(j-1) or gamma(l-1)
8219       if (j.gt.1) then
8220 #ifdef MOMENT
8221         s1=dipderg(3,jj,i)*dip(1,kk,k)
8222 #endif
8223         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8224         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8225         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8226         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8227         vv(1)=pizda(1,1)-pizda(2,2)
8228         vv(2)=pizda(1,2)+pizda(2,1)
8229         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8230 #ifdef MOMENT
8231         if (swap) then
8232           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8233         else
8234           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8235         endif
8236 #endif
8237         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8238 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8239       endif
8240 C Derivatives in gamma(l-1) or gamma(j-1)
8241       if (l.gt.1) then
8242 #ifdef MOMENT
8243         s1=dip(1,jj,i)*dipderg(3,kk,k)
8244 #endif
8245         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8246         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8247         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8248         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8249         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8250         vv(1)=pizda(1,1)-pizda(2,2)
8251         vv(2)=pizda(1,2)+pizda(2,1)
8252         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8253 #ifdef MOMENT
8254         if (swap) then
8255           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8256         else
8257           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8258         endif
8259 #endif
8260         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8261 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8262       endif
8263 C Cartesian derivatives.
8264       if (lprn) then
8265         write (2,*) 'In eello6_graph2'
8266         do iii=1,2
8267           write (2,*) 'iii=',iii
8268           do kkk=1,5
8269             write (2,*) 'kkk=',kkk
8270             do jjj=1,2
8271               write (2,'(3(2f10.5),5x)')
8272      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8273             enddo
8274           enddo
8275         enddo
8276       endif
8277       do iii=1,2
8278         do kkk=1,5
8279           do lll=1,3
8280 #ifdef MOMENT
8281             if (iii.eq.1) then
8282               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8283             else
8284               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8285             endif
8286 #endif
8287             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8288      &        auxvec(1))
8289             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8290             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8291      &        auxvec(1))
8292             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8293             call transpose2(EUg(1,1,k),auxmat(1,1))
8294             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8295      &        pizda(1,1))
8296             vv(1)=pizda(1,1)-pizda(2,2)
8297             vv(2)=pizda(1,2)+pizda(2,1)
8298             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8299 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8300 #ifdef MOMENT
8301             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8302 #else
8303             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8304 #endif
8305             if (swap) then
8306               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8307             else
8308               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8309             endif
8310           enddo
8311         enddo
8312       enddo
8313       return
8314       end
8315 c----------------------------------------------------------------------------
8316       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8317       implicit real*8 (a-h,o-z)
8318       include 'DIMENSIONS'
8319       include 'COMMON.IOUNITS'
8320       include 'COMMON.CHAIN'
8321       include 'COMMON.DERIV'
8322       include 'COMMON.INTERACT'
8323       include 'COMMON.CONTACTS'
8324       include 'COMMON.TORSION'
8325       include 'COMMON.VAR'
8326       include 'COMMON.GEO'
8327       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8328       logical swap
8329 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8330 C                                                                              C
8331 C      Parallel       Antiparallel                                             C
8332 C                                                                              C
8333 C          o             o                                                     C
8334 C         /l\   /   \   /j\                                                    C
8335 C        /   \ /     \ /   \                                                   C
8336 C       /| o |o       o| o |\                                                  C
8337 C       j|/k\|  /      |/k\|l /                                                C
8338 C        /   \ /       /   \ /                                                 C
8339 C       /     o       /     o                                                  C
8340 C       i             i                                                        C
8341 C                                                                              C
8342 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8343 C
8344 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8345 C           energy moment and not to the cluster cumulant.
8346       iti=itortyp(itype(i))
8347       if (j.lt.nres-1) then
8348         itj1=itortyp(itype(j+1))
8349       else
8350         itj1=ntortyp+1
8351       endif
8352       itk=itortyp(itype(k))
8353       itk1=itortyp(itype(k+1))
8354       if (l.lt.nres-1) then
8355         itl1=itortyp(itype(l+1))
8356       else
8357         itl1=ntortyp+1
8358       endif
8359 #ifdef MOMENT
8360       s1=dip(4,jj,i)*dip(4,kk,k)
8361 #endif
8362       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8363       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8364       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8365       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8366       call transpose2(EE(1,1,itk),auxmat(1,1))
8367       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8368       vv(1)=pizda(1,1)+pizda(2,2)
8369       vv(2)=pizda(2,1)-pizda(1,2)
8370       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8371 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8372 cd     & "sum",-(s2+s3+s4)
8373 #ifdef MOMENT
8374       eello6_graph3=-(s1+s2+s3+s4)
8375 #else
8376       eello6_graph3=-(s2+s3+s4)
8377 #endif
8378 c      eello6_graph3=-s4
8379 C Derivatives in gamma(k-1)
8380       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8381       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8382       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8383       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8384 C Derivatives in gamma(l-1)
8385       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8386       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8387       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8388       vv(1)=pizda(1,1)+pizda(2,2)
8389       vv(2)=pizda(2,1)-pizda(1,2)
8390       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8391       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8392 C Cartesian derivatives.
8393       do iii=1,2
8394         do kkk=1,5
8395           do lll=1,3
8396 #ifdef MOMENT
8397             if (iii.eq.1) then
8398               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8399             else
8400               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8401             endif
8402 #endif
8403             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8404      &        auxvec(1))
8405             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8406             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8407      &        auxvec(1))
8408             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8409             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8410      &        pizda(1,1))
8411             vv(1)=pizda(1,1)+pizda(2,2)
8412             vv(2)=pizda(2,1)-pizda(1,2)
8413             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8414 #ifdef MOMENT
8415             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8416 #else
8417             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8418 #endif
8419             if (swap) then
8420               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8421             else
8422               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8423             endif
8424 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8425           enddo
8426         enddo
8427       enddo
8428       return
8429       end
8430 c----------------------------------------------------------------------------
8431       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8432       implicit real*8 (a-h,o-z)
8433       include 'DIMENSIONS'
8434       include 'COMMON.IOUNITS'
8435       include 'COMMON.CHAIN'
8436       include 'COMMON.DERIV'
8437       include 'COMMON.INTERACT'
8438       include 'COMMON.CONTACTS'
8439       include 'COMMON.TORSION'
8440       include 'COMMON.VAR'
8441       include 'COMMON.GEO'
8442       include 'COMMON.FFIELD'
8443       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8444      & auxvec1(2),auxmat1(2,2)
8445       logical swap
8446 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8447 C                                                                              C
8448 C      Parallel       Antiparallel                                             C
8449 C                                                                              C
8450 C          o             o                                                     C
8451 C         /l\   /   \   /j\                                                    C
8452 C        /   \ /     \ /   \                                                   C
8453 C       /| o |o       o| o |\                                                  C
8454 C     \ j|/k\|      \  |/k\|l                                                  C
8455 C      \ /   \       \ /   \                                                   C
8456 C       o     \       o     \                                                  C
8457 C       i             i                                                        C
8458 C                                                                              C
8459 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8460 C
8461 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8462 C           energy moment and not to the cluster cumulant.
8463 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8464       iti=itortyp(itype(i))
8465       itj=itortyp(itype(j))
8466       if (j.lt.nres-1) then
8467         itj1=itortyp(itype(j+1))
8468       else
8469         itj1=ntortyp+1
8470       endif
8471       itk=itortyp(itype(k))
8472       if (k.lt.nres-1) then
8473         itk1=itortyp(itype(k+1))
8474       else
8475         itk1=ntortyp+1
8476       endif
8477       itl=itortyp(itype(l))
8478       if (l.lt.nres-1) then
8479         itl1=itortyp(itype(l+1))
8480       else
8481         itl1=ntortyp+1
8482       endif
8483 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8484 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8485 cd     & ' itl',itl,' itl1',itl1
8486 #ifdef MOMENT
8487       if (imat.eq.1) then
8488         s1=dip(3,jj,i)*dip(3,kk,k)
8489       else
8490         s1=dip(2,jj,j)*dip(2,kk,l)
8491       endif
8492 #endif
8493       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8494       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8495       if (j.eq.l+1) then
8496         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8497         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8498       else
8499         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8500         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8501       endif
8502       call transpose2(EUg(1,1,k),auxmat(1,1))
8503       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8504       vv(1)=pizda(1,1)-pizda(2,2)
8505       vv(2)=pizda(2,1)+pizda(1,2)
8506       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8507 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8508 #ifdef MOMENT
8509       eello6_graph4=-(s1+s2+s3+s4)
8510 #else
8511       eello6_graph4=-(s2+s3+s4)
8512 #endif
8513 C Derivatives in gamma(i-1)
8514       if (i.gt.1) then
8515 #ifdef MOMENT
8516         if (imat.eq.1) then
8517           s1=dipderg(2,jj,i)*dip(3,kk,k)
8518         else
8519           s1=dipderg(4,jj,j)*dip(2,kk,l)
8520         endif
8521 #endif
8522         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8523         if (j.eq.l+1) then
8524           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8525           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8526         else
8527           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8528           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8529         endif
8530         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8531         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8532 cd          write (2,*) 'turn6 derivatives'
8533 #ifdef MOMENT
8534           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8535 #else
8536           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8537 #endif
8538         else
8539 #ifdef MOMENT
8540           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8541 #else
8542           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8543 #endif
8544         endif
8545       endif
8546 C Derivatives in gamma(k-1)
8547 #ifdef MOMENT
8548       if (imat.eq.1) then
8549         s1=dip(3,jj,i)*dipderg(2,kk,k)
8550       else
8551         s1=dip(2,jj,j)*dipderg(4,kk,l)
8552       endif
8553 #endif
8554       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8555       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8556       if (j.eq.l+1) then
8557         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8558         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8559       else
8560         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8561         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8562       endif
8563       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8564       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8565       vv(1)=pizda(1,1)-pizda(2,2)
8566       vv(2)=pizda(2,1)+pizda(1,2)
8567       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8568       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8569 #ifdef MOMENT
8570         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8571 #else
8572         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8573 #endif
8574       else
8575 #ifdef MOMENT
8576         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8577 #else
8578         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8579 #endif
8580       endif
8581 C Derivatives in gamma(j-1) or gamma(l-1)
8582       if (l.eq.j+1 .and. l.gt.1) then
8583         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8584         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8585         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8586         vv(1)=pizda(1,1)-pizda(2,2)
8587         vv(2)=pizda(2,1)+pizda(1,2)
8588         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8589         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8590       else if (j.gt.1) then
8591         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8592         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8593         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8594         vv(1)=pizda(1,1)-pizda(2,2)
8595         vv(2)=pizda(2,1)+pizda(1,2)
8596         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8597         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8598           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8599         else
8600           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8601         endif
8602       endif
8603 C Cartesian derivatives.
8604       do iii=1,2
8605         do kkk=1,5
8606           do lll=1,3
8607 #ifdef MOMENT
8608             if (iii.eq.1) then
8609               if (imat.eq.1) then
8610                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8611               else
8612                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8613               endif
8614             else
8615               if (imat.eq.1) then
8616                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8617               else
8618                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8619               endif
8620             endif
8621 #endif
8622             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8623      &        auxvec(1))
8624             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8625             if (j.eq.l+1) then
8626               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8627      &          b1(1,j+1),auxvec(1))
8628               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8629             else
8630               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8631      &          b1(1,l+1),auxvec(1))
8632               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8633             endif
8634             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8635      &        pizda(1,1))
8636             vv(1)=pizda(1,1)-pizda(2,2)
8637             vv(2)=pizda(2,1)+pizda(1,2)
8638             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8639             if (swap) then
8640               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8641 #ifdef MOMENT
8642                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8643      &             -(s1+s2+s4)
8644 #else
8645                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8646      &             -(s2+s4)
8647 #endif
8648                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8649               else
8650 #ifdef MOMENT
8651                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8652 #else
8653                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8654 #endif
8655                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8656               endif
8657             else
8658 #ifdef MOMENT
8659               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8660 #else
8661               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8662 #endif
8663               if (l.eq.j+1) then
8664                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8665               else
8666                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8667               endif
8668             endif
8669           enddo
8670         enddo
8671       enddo
8672       return
8673       end
8674 c----------------------------------------------------------------------------
8675       double precision function eello_turn6(i,jj,kk)
8676       implicit real*8 (a-h,o-z)
8677       include 'DIMENSIONS'
8678       include 'COMMON.IOUNITS'
8679       include 'COMMON.CHAIN'
8680       include 'COMMON.DERIV'
8681       include 'COMMON.INTERACT'
8682       include 'COMMON.CONTACTS'
8683       include 'COMMON.TORSION'
8684       include 'COMMON.VAR'
8685       include 'COMMON.GEO'
8686       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8687      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8688      &  ggg1(3),ggg2(3)
8689       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8690      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8691 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8692 C           the respective energy moment and not to the cluster cumulant.
8693       s1=0.0d0
8694       s8=0.0d0
8695       s13=0.0d0
8696 c
8697       eello_turn6=0.0d0
8698       j=i+4
8699       k=i+1
8700       l=i+3
8701       iti=itortyp(itype(i))
8702       itk=itortyp(itype(k))
8703       itk1=itortyp(itype(k+1))
8704       itl=itortyp(itype(l))
8705       itj=itortyp(itype(j))
8706 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8707 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8708 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8709 cd        eello6=0.0d0
8710 cd        return
8711 cd      endif
8712 cd      write (iout,*)
8713 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8714 cd     &   ' and',k,l
8715 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8716       do iii=1,2
8717         do kkk=1,5
8718           do lll=1,3
8719             derx_turn(lll,kkk,iii)=0.0d0
8720           enddo
8721         enddo
8722       enddo
8723 cd      eij=1.0d0
8724 cd      ekl=1.0d0
8725 cd      ekont=1.0d0
8726       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8727 cd      eello6_5=0.0d0
8728 cd      write (2,*) 'eello6_5',eello6_5
8729 #ifdef MOMENT
8730       call transpose2(AEA(1,1,1),auxmat(1,1))
8731       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8732       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8733       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8734 #endif
8735       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8736       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8737       s2 = scalar2(b1(1,k),vtemp1(1))
8738 #ifdef MOMENT
8739       call transpose2(AEA(1,1,2),atemp(1,1))
8740       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8741       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8742       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8743 #endif
8744       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8745       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8746       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8747 #ifdef MOMENT
8748       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8749       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8750       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8751       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8752       ss13 = scalar2(b1(1,k),vtemp4(1))
8753       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8754 #endif
8755 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8756 c      s1=0.0d0
8757 c      s2=0.0d0
8758 c      s8=0.0d0
8759 c      s12=0.0d0
8760 c      s13=0.0d0
8761       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8762 C Derivatives in gamma(i+2)
8763       s1d =0.0d0
8764       s8d =0.0d0
8765 #ifdef MOMENT
8766       call transpose2(AEA(1,1,1),auxmatd(1,1))
8767       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8768       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8769       call transpose2(AEAderg(1,1,2),atempd(1,1))
8770       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8771       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8772 #endif
8773       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8774       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8775       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8776 c      s1d=0.0d0
8777 c      s2d=0.0d0
8778 c      s8d=0.0d0
8779 c      s12d=0.0d0
8780 c      s13d=0.0d0
8781       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8782 C Derivatives in gamma(i+3)
8783 #ifdef MOMENT
8784       call transpose2(AEA(1,1,1),auxmatd(1,1))
8785       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8786       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8787       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8788 #endif
8789       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8790       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8791       s2d = scalar2(b1(1,k),vtemp1d(1))
8792 #ifdef MOMENT
8793       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8794       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8795 #endif
8796       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8797 #ifdef MOMENT
8798       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8799       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8800       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8801 #endif
8802 c      s1d=0.0d0
8803 c      s2d=0.0d0
8804 c      s8d=0.0d0
8805 c      s12d=0.0d0
8806 c      s13d=0.0d0
8807 #ifdef MOMENT
8808       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8809      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8810 #else
8811       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8812      &               -0.5d0*ekont*(s2d+s12d)
8813 #endif
8814 C Derivatives in gamma(i+4)
8815       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8816       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8817       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8818 #ifdef MOMENT
8819       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8820       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8821       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8822 #endif
8823 c      s1d=0.0d0
8824 c      s2d=0.0d0
8825 c      s8d=0.0d0
8826 C      s12d=0.0d0
8827 c      s13d=0.0d0
8828 #ifdef MOMENT
8829       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8830 #else
8831       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8832 #endif
8833 C Derivatives in gamma(i+5)
8834 #ifdef MOMENT
8835       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8836       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8837       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8838 #endif
8839       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8840       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8841       s2d = scalar2(b1(1,k),vtemp1d(1))
8842 #ifdef MOMENT
8843       call transpose2(AEA(1,1,2),atempd(1,1))
8844       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8845       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8846 #endif
8847       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8848       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8849 #ifdef MOMENT
8850       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8851       ss13d = scalar2(b1(1,k),vtemp4d(1))
8852       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8853 #endif
8854 c      s1d=0.0d0
8855 c      s2d=0.0d0
8856 c      s8d=0.0d0
8857 c      s12d=0.0d0
8858 c      s13d=0.0d0
8859 #ifdef MOMENT
8860       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8861      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8862 #else
8863       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8864      &               -0.5d0*ekont*(s2d+s12d)
8865 #endif
8866 C Cartesian derivatives
8867       do iii=1,2
8868         do kkk=1,5
8869           do lll=1,3
8870 #ifdef MOMENT
8871             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8872             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8873             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8874 #endif
8875             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8876             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8877      &          vtemp1d(1))
8878             s2d = scalar2(b1(1,k),vtemp1d(1))
8879 #ifdef MOMENT
8880             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8881             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8882             s8d = -(atempd(1,1)+atempd(2,2))*
8883      &           scalar2(cc(1,1,itl),vtemp2(1))
8884 #endif
8885             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8886      &           auxmatd(1,1))
8887             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8888             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8889 c      s1d=0.0d0
8890 c      s2d=0.0d0
8891 c      s8d=0.0d0
8892 c      s12d=0.0d0
8893 c      s13d=0.0d0
8894 #ifdef MOMENT
8895             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8896      &        - 0.5d0*(s1d+s2d)
8897 #else
8898             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8899      &        - 0.5d0*s2d
8900 #endif
8901 #ifdef MOMENT
8902             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8903      &        - 0.5d0*(s8d+s12d)
8904 #else
8905             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8906      &        - 0.5d0*s12d
8907 #endif
8908           enddo
8909         enddo
8910       enddo
8911 #ifdef MOMENT
8912       do kkk=1,5
8913         do lll=1,3
8914           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8915      &      achuj_tempd(1,1))
8916           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8917           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8918           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8919           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8920           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8921      &      vtemp4d(1))
8922           ss13d = scalar2(b1(1,k),vtemp4d(1))
8923           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8924           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8925         enddo
8926       enddo
8927 #endif
8928 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8929 cd     &  16*eel_turn6_num
8930 cd      goto 1112
8931       if (j.lt.nres-1) then
8932         j1=j+1
8933         j2=j-1
8934       else
8935         j1=j-1
8936         j2=j-2
8937       endif
8938       if (l.lt.nres-1) then
8939         l1=l+1
8940         l2=l-1
8941       else
8942         l1=l-1
8943         l2=l-2
8944       endif
8945       do ll=1,3
8946 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8947 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8948 cgrad        ghalf=0.5d0*ggg1(ll)
8949 cd        ghalf=0.0d0
8950         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8951         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8952         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8953      &    +ekont*derx_turn(ll,2,1)
8954         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8955         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8956      &    +ekont*derx_turn(ll,4,1)
8957         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8958         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8959         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8960 cgrad        ghalf=0.5d0*ggg2(ll)
8961 cd        ghalf=0.0d0
8962         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8963      &    +ekont*derx_turn(ll,2,2)
8964         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8965         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8966      &    +ekont*derx_turn(ll,4,2)
8967         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8968         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8969         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8970       enddo
8971 cd      goto 1112
8972 cgrad      do m=i+1,j-1
8973 cgrad        do ll=1,3
8974 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8975 cgrad        enddo
8976 cgrad      enddo
8977 cgrad      do m=k+1,l-1
8978 cgrad        do ll=1,3
8979 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8980 cgrad        enddo
8981 cgrad      enddo
8982 cgrad1112  continue
8983 cgrad      do m=i+2,j2
8984 cgrad        do ll=1,3
8985 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8986 cgrad        enddo
8987 cgrad      enddo
8988 cgrad      do m=k+2,l2
8989 cgrad        do ll=1,3
8990 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8991 cgrad        enddo
8992 cgrad      enddo
8993 cd      do iii=1,nres-3
8994 cd        write (2,*) iii,g_corr6_loc(iii)
8995 cd      enddo
8996       eello_turn6=ekont*eel_turn6
8997 cd      write (2,*) 'ekont',ekont
8998 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8999       return
9000       end
9001
9002 C-----------------------------------------------------------------------------
9003       double precision function scalar(u,v)
9004 !DIR$ INLINEALWAYS scalar
9005 #ifndef OSF
9006 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9007 #endif
9008       implicit none
9009       double precision u(3),v(3)
9010 cd      double precision sc
9011 cd      integer i
9012 cd      sc=0.0d0
9013 cd      do i=1,3
9014 cd        sc=sc+u(i)*v(i)
9015 cd      enddo
9016 cd      scalar=sc
9017
9018       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9019       return
9020       end
9021 crc-------------------------------------------------
9022       SUBROUTINE MATVEC2(A1,V1,V2)
9023 !DIR$ INLINEALWAYS MATVEC2
9024 #ifndef OSF
9025 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9026 #endif
9027       implicit real*8 (a-h,o-z)
9028       include 'DIMENSIONS'
9029       DIMENSION A1(2,2),V1(2),V2(2)
9030 c      DO 1 I=1,2
9031 c        VI=0.0
9032 c        DO 3 K=1,2
9033 c    3     VI=VI+A1(I,K)*V1(K)
9034 c        Vaux(I)=VI
9035 c    1 CONTINUE
9036
9037       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9038       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9039
9040       v2(1)=vaux1
9041       v2(2)=vaux2
9042       END
9043 C---------------------------------------
9044       SUBROUTINE MATMAT2(A1,A2,A3)
9045 #ifndef OSF
9046 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9047 #endif
9048       implicit real*8 (a-h,o-z)
9049       include 'DIMENSIONS'
9050       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9051 c      DIMENSION AI3(2,2)
9052 c        DO  J=1,2
9053 c          A3IJ=0.0
9054 c          DO K=1,2
9055 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9056 c          enddo
9057 c          A3(I,J)=A3IJ
9058 c       enddo
9059 c      enddo
9060
9061       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9062       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9063       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9064       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9065
9066       A3(1,1)=AI3_11
9067       A3(2,1)=AI3_21
9068       A3(1,2)=AI3_12
9069       A3(2,2)=AI3_22
9070       END
9071
9072 c-------------------------------------------------------------------------
9073       double precision function scalar2(u,v)
9074 !DIR$ INLINEALWAYS scalar2
9075       implicit none
9076       double precision u(2),v(2)
9077       double precision sc
9078       integer i
9079       scalar2=u(1)*v(1)+u(2)*v(2)
9080       return
9081       end
9082
9083 C-----------------------------------------------------------------------------
9084
9085       subroutine transpose2(a,at)
9086 !DIR$ INLINEALWAYS transpose2
9087 #ifndef OSF
9088 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9089 #endif
9090       implicit none
9091       double precision a(2,2),at(2,2)
9092       at(1,1)=a(1,1)
9093       at(1,2)=a(2,1)
9094       at(2,1)=a(1,2)
9095       at(2,2)=a(2,2)
9096       return
9097       end
9098 c--------------------------------------------------------------------------
9099       subroutine transpose(n,a,at)
9100       implicit none
9101       integer n,i,j
9102       double precision a(n,n),at(n,n)
9103       do i=1,n
9104         do j=1,n
9105           at(j,i)=a(i,j)
9106         enddo
9107       enddo
9108       return
9109       end
9110 C---------------------------------------------------------------------------
9111       subroutine prodmat3(a1,a2,kk,transp,prod)
9112 !DIR$ INLINEALWAYS prodmat3
9113 #ifndef OSF
9114 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9115 #endif
9116       implicit none
9117       integer i,j
9118       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9119       logical transp
9120 crc      double precision auxmat(2,2),prod_(2,2)
9121
9122       if (transp) then
9123 crc        call transpose2(kk(1,1),auxmat(1,1))
9124 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9125 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9126
9127            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9128      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9129            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9130      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9131            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9132      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9133            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9134      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9135
9136       else
9137 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9138 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9139
9140            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9141      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9142            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9143      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9144            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9145      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9146            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9147      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9148
9149       endif
9150 c      call transpose2(a2(1,1),a2t(1,1))
9151
9152 crc      print *,transp
9153 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9154 crc      print *,((prod(i,j),i=1,2),j=1,2)
9155
9156       return
9157       end
9158