source/unres/src_MD-restraints/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       call flush(iout)
  31       if (nfgtasks.gt.1) then
  32 #ifdef MPI
  33         time00=MPI_Wtime()
  34 #else
  35         time00=tcpu()
  36 #endif
  37 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  38         if (fg_rank.eq.0) then
  39           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  40 c          print *,"Processor",myrank," BROADCAST iorder"
  41 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  42 C FG slaves as WEIGHTS array.
  43           weights_(1)=wsc
  44           weights_(2)=wscp
  45           weights_(3)=welec
  46           weights_(4)=wcorr
  47           weights_(5)=wcorr5
  48           weights_(6)=wcorr6
  49           weights_(7)=wel_loc
  50           weights_(8)=wturn3
  51           weights_(9)=wturn4
  52           weights_(10)=wturn6
  53           weights_(11)=wang
  54           weights_(12)=wscloc
  55           weights_(13)=wtor
  56           weights_(14)=wtor_d
  57           weights_(15)=wstrain
  58           weights_(16)=wvdwpp
  59           weights_(17)=wbond
  60           weights_(18)=scal14
  61           weights_(21)=wsccor
  62           weights_(22)=wsct
  63 C FG Master broadcasts the WEIGHTS_ array
  64           call MPI_Bcast(weights_(1),n_ene,
  65      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  66         else
  67 C FG slaves receive the WEIGHTS array
  68           call MPI_Bcast(weights(1),n_ene,
  69      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  70           wsc=weights(1)
  71           wscp=weights(2)
  72           welec=weights(3)
  73           wcorr=weights(4)
  74           wcorr5=weights(5)
  75           wcorr6=weights(6)
  76           wel_loc=weights(7)
  77           wturn3=weights(8)
  78           wturn4=weights(9)
  79           wturn6=weights(10)
  80           wang=weights(11)
  81           wscloc=weights(12)
  82           wtor=weights(13)
  83           wtor_d=weights(14)
  84           wstrain=weights(15)
  85           wvdwpp=weights(16)
  86           wbond=weights(17)
  87           scal14=weights(18)
  88           wsccor=weights(21)
  89           wsct=weights(22)
  90         endif
  91         time_Bcast=time_Bcast+MPI_Wtime()-time00
  92         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  93 c        call chainbuild_cart
  94       endif
  95 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  96 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  97 #else
  98 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  99 c        call int_from_cart1(.false.)
 100 c      endif
 101 #endif
 102 #ifdef TIMING
 103 #ifdef MPI
 104       time00=MPI_Wtime()
 105 #else
 106       time00=tcpu()
 107 #endif
 108 #endif
 109 C
 110 C Compute the side-chain and electrostatic interaction energy
 111 C
 112       goto (101,102,103,104,105,106) ipot
 113 C Lennard-Jones potential.
 114   101 call elj(evdw,evdw_p,evdw_m)
 115 cd    print '(a)','Exit ELJ'
 116       goto 107
 117 C Lennard-Jones-Kihara potential (shifted).
 118   102 call eljk(evdw,evdw_p,evdw_m)
 119       goto 107
 120 C Berne-Pechukas potential (dilated LJ, angular dependence).
 121   103 call ebp(evdw,evdw_p,evdw_m)
 122       goto 107
 123 C Gay-Berne potential (shifted LJ, angular dependence).
 124   104 call egb(evdw,evdw_p,evdw_m)
 125       goto 107
 126 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 127   105 call egbv(evdw,evdw_p,evdw_m)
 128       goto 107
 129 C Soft-sphere potential
 130   106 call e_softsphere(evdw)
 131 C
 132 C Calculate electrostatic (H-bonding) energy of the main chain.
 133 C
 134   107 continue
 135 cmc
 136 cmc Sep-06: egb takes care of dynamic ss bonds too
 137 cmc
 138 c      if (dyn_ss) call dyn_set_nss
 139
 140 c      print *,"Processor",myrank," computed USCSC"
 141 #ifdef TIMING
 142 #ifdef MPI
 143       time01=MPI_Wtime()
 144 #else
 145       time00=tcpu()
 146 #endif
 147 #endif
 148       call vec_and_deriv
 149 #ifdef TIMING
 150 #ifdef MPI
 151       time_vec=time_vec+MPI_Wtime()-time01
 152 #else
 153       time_vec=time_vec+tcpu()-time01
 154 #endif
 155 #endif
 156 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 157       if (ipot.lt.6) then
 158 #ifdef SPLITELE
 159          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 160      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 161      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 162      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 163 #else
 164          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 165      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 166      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 167      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 168 #endif
 169             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 170          else
 171             ees=0.0d0
 172             evdw1=0.0d0
 173             eel_loc=0.0d0
 174             eello_turn3=0.0d0
 175             eello_turn4=0.0d0
 176          endif
 177       else
 178 c        write (iout,*) "Soft-spheer ELEC potential"
 179         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 180      &   eello_turn4)
 181       endif
 182 c      print *,"Processor",myrank," computed UELEC"
 183 C
 184 C Calculate excluded-volume interaction energy between peptide groups
 185 C and side chains.
 186 C
 187       if (ipot.lt.6) then
 188        if(wscp.gt.0d0) then
 189         call escp(evdw2,evdw2_14)
 190        else
 191         evdw2=0
 192         evdw2_14=0
 193        endif
 194       else
 195 c        write (iout,*) "Soft-sphere SCP potential"
 196         call escp_soft_sphere(evdw2,evdw2_14)
 197       endif
 198 c
 199 c Calculate the bond-stretching energy
 200 c
 201       call ebond(estr)
 202 C
 203 C Calculate the disulfide-bridge and other energy and the contributions
 204 C from other distance constraints.
 205 cd    print *,'Calling EHPB'
 206       call edis(ehpb)
 207 cd    print *,'EHPB exitted succesfully.'
 208 C
 209 C Calculate the virtual-bond-angle energy.
 210 C
 211       if (wang.gt.0d0) then
 212         call ebend(ebe)
 213       else
 214         ebe=0
 215       endif
 216 c      print *,"Processor",myrank," computed UB"
 217 C
 218 C Calculate the SC local energy.
 219 C
 220       call esc(escloc)
 221 c      print *,"Processor",myrank," computed USC"
 222 C
 223 C Calculate the virtual-bond torsional energy.
 224 C
 225 cd    print *,'nterm=',nterm
 226       if (wtor.gt.0) then
 227        call etor(etors,edihcnstr)
 228       else
 229        etors=0
 230        edihcnstr=0
 231       endif
 232
 233       if (constr_homology.ge.1) then
 234         call e_modeller(ehomology_constr)
 235       else
 236         ehomology_constr=0.0d0
 237       endif
 238
 239
 240 c      write(iout,*) ehomology_constr
 241 c      print *,"Processor",myrank," computed Utor"
 242 C
 243 C 6/23/01 Calculate double-torsional energy
 244 C
 245       if (wtor_d.gt.0) then
 246        call etor_d(etors_d)
 247       else
 248        etors_d=0
 249       endif
 250 c      print *,"Processor",myrank," computed Utord"
 251 C
 252 C 21/5/07 Calculate local sicdechain correlation energy
 253 C
 254       if (wsccor.gt.0.0d0) then
 255         call eback_sc_corr(esccor)
 256       else
 257         esccor=0.0d0
 258       endif
 259 c      print *,"Processor",myrank," computed Usccorr"
 260 C
 261 C 12/1/95 Multi-body terms
 262 C
 263       n_corr=0
 264       n_corr1=0
 265       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 266      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 267          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 268 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 269 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 270       else
 271          ecorr=0.0d0
 272          ecorr5=0.0d0
 273          ecorr6=0.0d0
 274          eturn6=0.0d0
 275       endif
 276       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 277          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 278 cd         write (iout,*) "multibody_hb ecorr",ecorr
 279       endif
 280 c      print *,"Processor",myrank," computed Ucorr"
 281 C
 282 C If performing constraint dynamics, call the constraint energy
 283 C  after the equilibration time
 284       if(usampl.and.totT.gt.eq_time) then
 285          call EconstrQ
 286          call Econstr_back
 287       else
 288          Uconst=0.0d0
 289          Uconst_back=0.0d0
 290       endif
 291 #ifdef TIMING
 292 #ifdef MPI
 293       time_enecalc=time_enecalc+MPI_Wtime()-time00
 294 #else
 295       time_enecalc=time_enecalc+tcpu()-time00
 296 #endif
 297 #endif
 298 c      print *,"Processor",myrank," computed Uconstr"
 299 #ifdef TIMING
 300 #ifdef MPI
 301       time00=MPI_Wtime()
 302 #else
 303       time00=tcpu()
 304 #endif
 305 #endif
 306 c
 307 C Sum the energies
 308 C
 309       energia(1)=evdw
 310 #ifdef SCP14
 311       energia(2)=evdw2-evdw2_14
 312       energia(18)=evdw2_14
 313 #else
 314       energia(2)=evdw2
 315       energia(18)=0.0d0
 316 #endif
 317 #ifdef SPLITELE
 318       energia(3)=ees
 319       energia(16)=evdw1
 320 #else
 321       energia(3)=ees+evdw1
 322       energia(16)=0.0d0
 323 #endif
 324       energia(4)=ecorr
 325       energia(5)=ecorr5
 326       energia(6)=ecorr6
 327       energia(7)=eel_loc
 328       energia(8)=eello_turn3
 329       energia(9)=eello_turn4
 330       energia(10)=eturn6
 331       energia(11)=ebe
 332       energia(12)=escloc
 333       energia(13)=etors
 334       energia(14)=etors_d
 335       energia(15)=ehpb
 336       energia(19)=edihcnstr
 337       energia(17)=estr
 338       energia(20)=Uconst+Uconst_back
 339       energia(21)=esccor
 340       energia(22)=evdw_p
 341       energia(23)=evdw_m
 342       energia(24)=ehomology_constr
 343 c      print *," Processor",myrank," calls SUM_ENERGY"
 344       call sum_energy(energia,.true.)
 345       if (dyn_ss) call dyn_set_nss
 346 c      print *," Processor",myrank," left SUM_ENERGY"
 347 #ifdef TIMING
 348 #ifdef MPI
 349       time_sumene=time_sumene+MPI_Wtime()-time00
 350 #else
 351       time_sumene=time_sumene+tcpu()-time00
 352 #endif
 353 #endif
 354       return
 355       end
 356 c-------------------------------------------------------------------------------
 357       subroutine sum_energy(energia,reduce)
 358       implicit real*8 (a-h,o-z)
 359       include 'DIMENSIONS'
 360 #ifndef ISNAN
 361       external proc_proc
 362 #ifdef WINPGI
 363 cMS$ATTRIBUTES C ::  proc_proc
 364 #endif
 365 #endif
 366 #ifdef MPI
 367       include "mpif.h"
 368 #endif
 369       include 'COMMON.SETUP'
 370       include 'COMMON.IOUNITS'
 371       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 372       include 'COMMON.FFIELD'
 373       include 'COMMON.DERIV'
 374       include 'COMMON.INTERACT'
 375       include 'COMMON.SBRIDGE'
 376       include 'COMMON.CHAIN'
 377       include 'COMMON.VAR'
 378       include 'COMMON.CONTROL'
 379       include 'COMMON.TIME1'
 380       logical reduce
 381 #ifdef MPI
 382       if (nfgtasks.gt.1 .and. reduce) then
 383 #ifdef DEBUG
 384         write (iout,*) "energies before REDUCE"
 385         call enerprint(energia)
 386         call flush(iout)
 387 #endif
 388         do i=0,n_ene
 389           enebuff(i)=energia(i)
 390         enddo
 391         time00=MPI_Wtime()
 392         call MPI_Barrier(FG_COMM,IERR)
 393         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 394         time00=MPI_Wtime()
 395         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 396      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 397 #ifdef DEBUG
 398         write (iout,*) "energies after REDUCE"
 399         call enerprint(energia)
 400         call flush(iout)
 401 #endif
 402         time_Reduce=time_Reduce+MPI_Wtime()-time00
 403       endif
 404       if (fg_rank.eq.0) then
 405 #endif
 406 #ifdef TSCSC
 407       evdw=energia(22)+wsct*energia(23)
 408 #else
 409       evdw=energia(1)
 410 #endif
 411 #ifdef SCP14
 412       evdw2=energia(2)+energia(18)
 413       evdw2_14=energia(18)
 414 #else
 415       evdw2=energia(2)
 416 #endif
 417 #ifdef SPLITELE
 418       ees=energia(3)
 419       evdw1=energia(16)
 420 #else
 421       ees=energia(3)
 422       evdw1=0.0d0
 423 #endif
 424       ecorr=energia(4)
 425       ecorr5=energia(5)
 426       ecorr6=energia(6)
 427       eel_loc=energia(7)
 428       eello_turn3=energia(8)
 429       eello_turn4=energia(9)
 430       eturn6=energia(10)
 431       ebe=energia(11)
 432       escloc=energia(12)
 433       etors=energia(13)
 434       etors_d=energia(14)
 435       ehpb=energia(15)
 436       edihcnstr=energia(19)
 437       estr=energia(17)
 438       Uconst=energia(20)
 439       esccor=energia(21)
 440       ehomology_constr=energia(24)
 441 #ifdef SPLITELE
 442       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 443      & +wang*ebe+wtor*etors+wscloc*escloc
 444      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 445      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 446      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 447      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 448 #else
 449       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 450      & +wang*ebe+wtor*etors+wscloc*escloc
 451      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 452      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 453      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 454      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 455 #endif
 456       energia(0)=etot
 457 c detecting NaNQ
 458 #ifdef ISNAN
 459 #ifdef AIX
 460       if (isnan(etot).ne.0) energia(0)=1.0d+99
 461 #else
 462       if (isnan(etot)) energia(0)=1.0d+99
 463 #endif
 464 #else
 465       i=0
 466 #ifdef WINPGI
 467       idumm=proc_proc(etot,i)
 468 #else
 469       call proc_proc(etot,i)
 470 #endif
 471       if(i.eq.1)energia(0)=1.0d+99
 472 #endif
 473 #ifdef MPI
 474       endif
 475 #endif
 476       return
 477       end
 478 c-------------------------------------------------------------------------------
 479       subroutine sum_gradient
 480       implicit real*8 (a-h,o-z)
 481       include 'DIMENSIONS'
 482 #ifndef ISNAN
 483       external proc_proc
 484 #ifdef WINPGI
 485 cMS$ATTRIBUTES C ::  proc_proc
 486 #endif
 487 #endif
 488 #ifdef MPI
 489       include 'mpif.h'
 490 #endif
 491       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 492      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 493       include 'COMMON.SETUP'
 494       include 'COMMON.IOUNITS'
 495       include 'COMMON.FFIELD'
 496       include 'COMMON.DERIV'
 497       include 'COMMON.INTERACT'
 498       include 'COMMON.SBRIDGE'
 499       include 'COMMON.CHAIN'
 500       include 'COMMON.VAR'
 501       include 'COMMON.CONTROL'
 502       include 'COMMON.TIME1'
 503       include 'COMMON.MAXGRAD'
 504       include 'COMMON.SCCOR'
 505 #ifdef TIMING
 506 #ifdef MPI
 507       time01=MPI_Wtime()
 508 #else
 509       time01=tcpu()
 510 #endif
 511 #endif
 512 #ifdef DEBUG
 513       write (iout,*) "sum_gradient gvdwc, gvdwx"
 514       do i=1,nres
 515         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 516      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 517      &   (gvdwcT(j,i),j=1,3)
 518       enddo
 519       call flush(iout)
 520 #endif
 521 #ifdef MPI
 522 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 523         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 524      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 525 #endif
 526 C
 527 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 528 C            in virtual-bond-vector coordinates
 529 C
 530 #ifdef DEBUG
 531 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 532 c      do i=1,nres-1
 533 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 534 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 535 c      enddo
 536 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 537 c      do i=1,nres-1
 538 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 539 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 540 c      enddo
 541       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 542       do i=1,nres
 543         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 544      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 545      &   g_corr5_loc(i)
 546       enddo
 547       call flush(iout)
 548 #endif
 549 #ifdef SPLITELE
 550 #ifdef TSCSC
 551       do i=1,nct
 552         do j=1,3
 553           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 554      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 555      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 556      &                wel_loc*gel_loc_long(j,i)+
 557      &                wcorr*gradcorr_long(j,i)+
 558      &                wcorr5*gradcorr5_long(j,i)+
 559      &                wcorr6*gradcorr6_long(j,i)+
 560      &                wturn6*gcorr6_turn_long(j,i)+
 561      &                wstrain*ghpbc(j,i)
 562         enddo
 563       enddo
 564 #else
 565       do i=1,nct
 566         do j=1,3
 567           gradbufc(j,i)=wsc*gvdwc(j,i)+
 568      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 569      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 570      &                wel_loc*gel_loc_long(j,i)+
 571      &                wcorr*gradcorr_long(j,i)+
 572      &                wcorr5*gradcorr5_long(j,i)+
 573      &                wcorr6*gradcorr6_long(j,i)+
 574      &                wturn6*gcorr6_turn_long(j,i)+
 575      &                wstrain*ghpbc(j,i)
 576         enddo
 577       enddo
 578 #endif
 579 #else
 580       do i=1,nct
 581         do j=1,3
 582           gradbufc(j,i)=wsc*gvdwc(j,i)+
 583      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 584      &                welec*gelc_long(j,i)+
 585      &                wbond*gradb(j,i)+
 586      &                wel_loc*gel_loc_long(j,i)+
 587      &                wcorr*gradcorr_long(j,i)+
 588      &                wcorr5*gradcorr5_long(j,i)+
 589      &                wcorr6*gradcorr6_long(j,i)+
 590      &                wturn6*gcorr6_turn_long(j,i)+
 591      &                wstrain*ghpbc(j,i)
 592         enddo
 593       enddo
 594 #endif
 595 #ifdef MPI
 596       if (nfgtasks.gt.1) then
 597       time00=MPI_Wtime()
 598 #ifdef DEBUG
 599       write (iout,*) "gradbufc before allreduce"
 600       do i=1,nres
 601         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 602       enddo
 603       call flush(iout)
 604 #endif
 605       do i=1,nres
 606         do j=1,3
 607           gradbufc_sum(j,i)=gradbufc(j,i)
 608         enddo
 609       enddo
 610 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 611 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 612 c      time_reduce=time_reduce+MPI_Wtime()-time00
 613 #ifdef DEBUG
 614 c      write (iout,*) "gradbufc_sum after allreduce"
 615 c      do i=1,nres
 616 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 617 c      enddo
 618 c      call flush(iout)
 619 #endif
 620 #ifdef TIMING
 621 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 622 #endif
 623       do i=nnt,nres
 624         do k=1,3
 625           gradbufc(k,i)=0.0d0
 626         enddo
 627       enddo
 628 #ifdef DEBUG
 629       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 630       write (iout,*) (i," jgrad_start",jgrad_start(i),
 631      &                  " jgrad_end  ",jgrad_end(i),
 632      &                  i=igrad_start,igrad_end)
 633 #endif
 634 c
 635 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 636 c do not parallelize this part.
 637 c
 638 c      do i=igrad_start,igrad_end
 639 c        do j=jgrad_start(i),jgrad_end(i)
 640 c          do k=1,3
 641 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 642 c          enddo
 643 c        enddo
 644 c      enddo
 645       do j=1,3
 646         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 647       enddo
 648       do i=nres-2,nnt,-1
 649         do j=1,3
 650           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 651         enddo
 652       enddo
 653 #ifdef DEBUG
 654       write (iout,*) "gradbufc after summing"
 655       do i=1,nres
 656         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 657       enddo
 658       call flush(iout)
 659 #endif
 660       else
 661 #endif
 662 #ifdef DEBUG
 663       write (iout,*) "gradbufc"
 664       do i=1,nres
 665         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 666       enddo
 667       call flush(iout)
 668 #endif
 669       do i=1,nres
 670         do j=1,3
 671           gradbufc_sum(j,i)=gradbufc(j,i)
 672           gradbufc(j,i)=0.0d0
 673         enddo
 674       enddo
 675       do j=1,3
 676         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 677       enddo
 678       do i=nres-2,nnt,-1
 679         do j=1,3
 680           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 681         enddo
 682       enddo
 683 c      do i=nnt,nres-1
 684 c        do k=1,3
 685 c          gradbufc(k,i)=0.0d0
 686 c        enddo
 687 c        do j=i+1,nres
 688 c          do k=1,3
 689 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 690 c          enddo
 691 c        enddo
 692 c      enddo
 693 #ifdef DEBUG
 694       write (iout,*) "gradbufc after summing"
 695       do i=1,nres
 696         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 697       enddo
 698       call flush(iout)
 699 #endif
 700 #ifdef MPI
 701       endif
 702 #endif
 703       do k=1,3
 704         gradbufc(k,nres)=0.0d0
 705       enddo
 706       do i=1,nct
 707         do j=1,3
 708 #ifdef SPLITELE
 709           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 710      &                wel_loc*gel_loc(j,i)+
 711      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 712      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 713      &                wel_loc*gel_loc_long(j,i)+
 714      &                wcorr*gradcorr_long(j,i)+
 715      &                wcorr5*gradcorr5_long(j,i)+
 716      &                wcorr6*gradcorr6_long(j,i)+
 717      &                wturn6*gcorr6_turn_long(j,i))+
 718      &                wbond*gradb(j,i)+
 719      &                wcorr*gradcorr(j,i)+
 720      &                wturn3*gcorr3_turn(j,i)+
 721      &                wturn4*gcorr4_turn(j,i)+
 722      &                wcorr5*gradcorr5(j,i)+
 723      &                wcorr6*gradcorr6(j,i)+
 724      &                wturn6*gcorr6_turn(j,i)+
 725      &                wsccor*gsccorc(j,i)
 726      &               +wscloc*gscloc(j,i)
 727 #else
 728           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 729      &                wel_loc*gel_loc(j,i)+
 730      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 731      &                welec*gelc_long(j,i)+
 732      &                wel_loc*gel_loc_long(j,i)+
 733      &                wcorr*gcorr_long(j,i)+
 734      &                wcorr5*gradcorr5_long(j,i)+
 735      &                wcorr6*gradcorr6_long(j,i)+
 736      &                wturn6*gcorr6_turn_long(j,i))+
 737      &                wbond*gradb(j,i)+
 738      &                wcorr*gradcorr(j,i)+
 739      &                wturn3*gcorr3_turn(j,i)+
 740      &                wturn4*gcorr4_turn(j,i)+
 741      &                wcorr5*gradcorr5(j,i)+
 742      &                wcorr6*gradcorr6(j,i)+
 743      &                wturn6*gcorr6_turn(j,i)+
 744      &                wsccor*gsccorc(j,i)
 745      &               +wscloc*gscloc(j,i)
 746 #endif
 747 #ifdef TSCSC
 748           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 749      &                  wscp*gradx_scp(j,i)+
 750      &                  wbond*gradbx(j,i)+
 751      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 752      &                  wsccor*gsccorx(j,i)
 753      &                 +wscloc*gsclocx(j,i)
 754 #else
 755           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 756      &                  wbond*gradbx(j,i)+
 757      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 758      &                  wsccor*gsccorx(j,i)
 759      &                 +wscloc*gsclocx(j,i)
 760 #endif
 761         enddo
 762       enddo
 763 #ifdef DEBUG
 764       write (iout,*) "gloc before adding corr"
 765       do i=1,4*nres
 766         write (iout,*) i,gloc(i,icg)
 767       enddo
 768 #endif
 769       do i=1,nres-3
 770         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 771      &   +wcorr5*g_corr5_loc(i)
 772      &   +wcorr6*g_corr6_loc(i)
 773      &   +wturn4*gel_loc_turn4(i)
 774      &   +wturn3*gel_loc_turn3(i)
 775      &   +wturn6*gel_loc_turn6(i)
 776      &   +wel_loc*gel_loc_loc(i)
 777       enddo
 778 #ifdef DEBUG
 779       write (iout,*) "gloc after adding corr"
 780       do i=1,4*nres
 781         write (iout,*) i,gloc(i,icg)
 782       enddo
 783 #endif
 784 #ifdef MPI
 785       if (nfgtasks.gt.1) then
 786         do j=1,3
 787           do i=1,nres
 788             gradbufc(j,i)=gradc(j,i,icg)
 789             gradbufx(j,i)=gradx(j,i,icg)
 790           enddo
 791         enddo
 792         do i=1,4*nres
 793           glocbuf(i)=gloc(i,icg)
 794         enddo
 795 #ifdef DEBUG
 796       write (iout,*) "gloc_sc before reduce"
 797       do i=1,nres
 798        do j=1,3
 799         write (iout,*) i,j,gloc_sc(j,i,icg)
 800        enddo
 801       enddo
 802 #endif
 803         do i=1,nres
 804          do j=1,3
 805           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 806          enddo
 807         enddo
 808         time00=MPI_Wtime()
 809         call MPI_Barrier(FG_COMM,IERR)
 810         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 811         time00=MPI_Wtime()
 812         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 813      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 814         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 815      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 816         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 817      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 818         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 819      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 820         time_reduce=time_reduce+MPI_Wtime()-time00
 821 #ifdef DEBUG
 822       write (iout,*) "gloc_sc after reduce"
 823       do i=1,nres
 824        do j=1,3
 825         write (iout,*) i,j,gloc_sc(j,i,icg)
 826        enddo
 827       enddo
 828 #endif
 829 #ifdef DEBUG
 830       write (iout,*) "gloc after reduce"
 831       do i=1,4*nres
 832         write (iout,*) i,gloc(i,icg)
 833       enddo
 834 #endif
 835       endif
 836 #endif
 837       if (gnorm_check) then
 838 c
 839 c Compute the maximum elements of the gradient
 840 c
 841       gvdwc_max=0.0d0
 842       gvdwc_scp_max=0.0d0
 843       gelc_max=0.0d0
 844       gvdwpp_max=0.0d0
 845       gradb_max=0.0d0
 846       ghpbc_max=0.0d0
 847       gradcorr_max=0.0d0
 848       gel_loc_max=0.0d0
 849       gcorr3_turn_max=0.0d0
 850       gcorr4_turn_max=0.0d0
 851       gradcorr5_max=0.0d0
 852       gradcorr6_max=0.0d0
 853       gcorr6_turn_max=0.0d0
 854       gsccorc_max=0.0d0
 855       gscloc_max=0.0d0
 856       gvdwx_max=0.0d0
 857       gradx_scp_max=0.0d0
 858       ghpbx_max=0.0d0
 859       gradxorr_max=0.0d0
 860       gsccorx_max=0.0d0
 861       gsclocx_max=0.0d0
 862       do i=1,nct
 863         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 864         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 865 #ifdef TSCSC
 866         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 867         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 868 #endif
 869         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 870         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 871      &   gvdwc_scp_max=gvdwc_scp_norm
 872         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 873         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 874         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 875         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 876         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 877         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 878         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 879         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 880         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 881         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 882         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 883         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 884         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 885      &    gcorr3_turn(1,i)))
 886         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 887      &    gcorr3_turn_max=gcorr3_turn_norm
 888         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 889      &    gcorr4_turn(1,i)))
 890         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 891      &    gcorr4_turn_max=gcorr4_turn_norm
 892         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 893         if (gradcorr5_norm.gt.gradcorr5_max)
 894      &    gradcorr5_max=gradcorr5_norm
 895         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 896         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 897         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 898      &    gcorr6_turn(1,i)))
 899         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 900      &    gcorr6_turn_max=gcorr6_turn_norm
 901         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 902         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 903         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 904         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 905         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 906         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 907 #ifdef TSCSC
 908         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 909         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 910 #endif
 911         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 912         if (gradx_scp_norm.gt.gradx_scp_max)
 913      &    gradx_scp_max=gradx_scp_norm
 914         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 915         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 916         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 917         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 918         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 919         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 920         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 921         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 922       enddo
 923       if (gradout) then
 924 #ifdef AIX
 925         open(istat,file=statname,position="append")
 926 #else
 927         open(istat,file=statname,access="append")
 928 #endif
 929         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 930      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 931      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 932      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 933      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 934      &     gsccorx_max,gsclocx_max
 935         close(istat)
 936         if (gvdwc_max.gt.1.0d4) then
 937           write (iout,*) "gvdwc gvdwx gradb gradbx"
 938           do i=nnt,nct
 939             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 940      &        gradb(j,i),gradbx(j,i),j=1,3)
 941           enddo
 942           call pdbout(0.0d0,'cipiszcze',iout)
 943           call flush(iout)
 944         endif
 945       endif
 946       endif
 947 #ifdef DEBUG
 948       write (iout,*) "gradc gradx gloc"
 949       do i=1,nres
 950         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 951      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 952       enddo
 953 #endif
 954 #ifdef TIMING
 955 #ifdef MPI
 956       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 957 #else
 958       time_sumgradient=time_sumgradient+tcpu()-time01
 959 #endif
 960 #endif
 961       return
 962       end
 963 c-------------------------------------------------------------------------------
 964       subroutine rescale_weights(t_bath)
 965       implicit real*8 (a-h,o-z)
 966       include 'DIMENSIONS'
 967       include 'COMMON.IOUNITS'
 968       include 'COMMON.FFIELD'
 969       include 'COMMON.SBRIDGE'
 970       double precision kfac /2.4d0/
 971       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 972 c      facT=temp0/t_bath
 973 c      facT=2*temp0/(t_bath+temp0)
 974       if (rescale_mode.eq.0) then
 975         facT=1.0d0
 976         facT2=1.0d0
 977         facT3=1.0d0
 978         facT4=1.0d0
 979         facT5=1.0d0
 980       else if (rescale_mode.eq.1) then
 981         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 982         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 983         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 984         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 985         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 986       else if (rescale_mode.eq.2) then
 987         x=t_bath/temp0
 988         x2=x*x
 989         x3=x2*x
 990         x4=x3*x
 991         x5=x4*x
 992         facT=licznik/dlog(dexp(x)+dexp(-x))
 993         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 994         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 995         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 996         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 997       else
 998         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 999         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1000 #ifdef MPI
1001        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1002 #endif
1003        stop 555
1004       endif
1005       welec=weights(3)*fact
1006       wcorr=weights(4)*fact3
1007       wcorr5=weights(5)*fact4
1008       wcorr6=weights(6)*fact5
1009       wel_loc=weights(7)*fact2
1010       wturn3=weights(8)*fact2
1011       wturn4=weights(9)*fact3
1012       wturn6=weights(10)*fact5
1013       wtor=weights(13)*fact
1014       wtor_d=weights(14)*fact2
1015       wsccor=weights(21)*fact
1016 #ifdef TSCSC
1017 c      wsct=t_bath/temp0
1018       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1019 #endif
1020       return
1021       end
1022 C------------------------------------------------------------------------
1023       subroutine enerprint(energia)
1024       implicit real*8 (a-h,o-z)
1025       include 'DIMENSIONS'
1026       include 'COMMON.IOUNITS'
1027       include 'COMMON.FFIELD'
1028       include 'COMMON.SBRIDGE'
1029       include 'COMMON.MD'
1030       double precision energia(0:n_ene)
1031       etot=energia(0)
1032 #ifdef TSCSC
1033       evdw=energia(22)+wsct*energia(23)
1034 #else
1035       evdw=energia(1)
1036 #endif
1037       evdw2=energia(2)
1038 #ifdef SCP14
1039       evdw2=energia(2)+energia(18)
1040 #else
1041       evdw2=energia(2)
1042 #endif
1043       ees=energia(3)
1044 #ifdef SPLITELE
1045       evdw1=energia(16)
1046 #endif
1047       ecorr=energia(4)
1048       ecorr5=energia(5)
1049       ecorr6=energia(6)
1050       eel_loc=energia(7)
1051       eello_turn3=energia(8)
1052       eello_turn4=energia(9)
1053       eello_turn6=energia(10)
1054       ebe=energia(11)
1055       escloc=energia(12)
1056       etors=energia(13)
1057       etors_d=energia(14)
1058       ehpb=energia(15)
1059       edihcnstr=energia(19)
1060       estr=energia(17)
1061       Uconst=energia(20)
1062       esccor=energia(21)
1063       ehomology_constr=energia(24)
1064
1065 #ifdef SPLITELE
1066       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1067      &  estr,wbond,ebe,wang,
1068      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1069      &  ecorr,wcorr,
1070      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1071      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1072      &  edihcnstr,ehomology_constr, ebr*nss,
1073      &  Uconst,etot
1074    10 format (/'Virtual-chain energies:'//
1075      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1076      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1077      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1078      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1079      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1080      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1081      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1082      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1083      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1084      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1085      & ' (SS bridges & dist. cnstr.)'/
1086      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1087      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1088      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1089      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1090      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1091      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1092      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1093      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1094      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1095      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1096      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1097      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1098      & 'ETOT=  ',1pE16.6,' (total)')
1099 #else
1100       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1101      &  estr,wbond,ebe,wang,
1102      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1103      &  ecorr,wcorr,
1104      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1105      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1106      &  ehomology_constr,ebr*nss,Uconst,etot
1107    10 format (/'Virtual-chain energies:'//
1108      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1109      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1110      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1111      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1112      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1113      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1114      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1115      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1116      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1117      & ' (SS bridges & dist. cnstr.)'/
1118      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1119      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1120      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1121      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1122      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1123      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1124      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1125      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1126      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1127      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1128      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1129      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1130      & 'ETOT=  ',1pE16.6,' (total)')
1131 #endif
1132       return
1133       end
1134 C-----------------------------------------------------------------------
1135       subroutine elj(evdw,evdw_p,evdw_m)
1136 C
1137 C This subroutine calculates the interaction energy of nonbonded side chains
1138 C assuming the LJ potential of interaction.
1139 C
1140       implicit real*8 (a-h,o-z)
1141       include 'DIMENSIONS'
1142       parameter (accur=1.0d-10)
1143       include 'COMMON.GEO'
1144       include 'COMMON.VAR'
1145       include 'COMMON.LOCAL'
1146       include 'COMMON.CHAIN'
1147       include 'COMMON.DERIV'
1148       include 'COMMON.INTERACT'
1149       include 'COMMON.TORSION'
1150       include 'COMMON.SBRIDGE'
1151       include 'COMMON.NAMES'
1152       include 'COMMON.IOUNITS'
1153       include 'COMMON.CONTACTS'
1154       dimension gg(3)
1155 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1156       evdw=0.0D0
1157       do i=iatsc_s,iatsc_e
1158         itypi=itype(i)
1159         itypi1=itype(i+1)
1160         xi=c(1,nres+i)
1161         yi=c(2,nres+i)
1162         zi=c(3,nres+i)
1163 C Change 12/1/95
1164         num_conti=0
1165 C
1166 C Calculate SC interaction energy.
1167 C
1168         do iint=1,nint_gr(i)
1169 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1170 cd   &                  'iend=',iend(i,iint)
1171           do j=istart(i,iint),iend(i,iint)
1172             itypj=itype(j)
1173             xj=c(1,nres+j)-xi
1174             yj=c(2,nres+j)-yi
1175             zj=c(3,nres+j)-zi
1176 C Change 12/1/95 to calculate four-body interactions
1177             rij=xj*xj+yj*yj+zj*zj
1178             rrij=1.0D0/rij
1179 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1180             eps0ij=eps(itypi,itypj)
1181             fac=rrij**expon2
1182             e1=fac*fac*aa(itypi,itypj)
1183             e2=fac*bb(itypi,itypj)
1184             evdwij=e1+e2
1185 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1186 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1187 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1188 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1189 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1190 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1191 #ifdef TSCSC
1192             if (bb(itypi,itypj).gt.0) then
1193                evdw_p=evdw_p+evdwij
1194             else
1195                evdw_m=evdw_m+evdwij
1196             endif
1197 #else
1198             evdw=evdw+evdwij
1199 #endif
1200 C
1201 C Calculate the components of the gradient in DC and X
1202 C
1203             fac=-rrij*(e1+evdwij)
1204             gg(1)=xj*fac
1205             gg(2)=yj*fac
1206             gg(3)=zj*fac
1207 #ifdef TSCSC
1208             if (bb(itypi,itypj).gt.0.0d0) then
1209               do k=1,3
1210                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1211                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1212                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1213                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1214               enddo
1215             else
1216               do k=1,3
1217                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1218                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1219                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1220                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1221               enddo
1222             endif
1223 #else
1224             do k=1,3
1225               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1226               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1227               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1228               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1229             enddo
1230 #endif
1231 cgrad            do k=i,j-1
1232 cgrad              do l=1,3
1233 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1234 cgrad              enddo
1235 cgrad            enddo
1236 C
1237 C 12/1/95, revised on 5/20/97
1238 C
1239 C Calculate the contact function. The ith column of the array JCONT will
1240 C contain the numbers of atoms that make contacts with the atom I (of numbers
1241 C greater than I). The arrays FACONT and GACONT will contain the values of
1242 C the contact function and its derivative.
1243 C
1244 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1245 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1246 C Uncomment next line, if the correlation interactions are contact function only
1247             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1248               rij=dsqrt(rij)
1249               sigij=sigma(itypi,itypj)
1250               r0ij=rs0(itypi,itypj)
1251 C
1252 C Check whether the SC's are not too far to make a contact.
1253 C
1254               rcut=1.5d0*r0ij
1255               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1256 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1257 C
1258               if (fcont.gt.0.0D0) then
1259 C If the SC-SC distance if close to sigma, apply spline.
1260 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1261 cAdam &             fcont1,fprimcont1)
1262 cAdam           fcont1=1.0d0-fcont1
1263 cAdam           if (fcont1.gt.0.0d0) then
1264 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1265 cAdam             fcont=fcont*fcont1
1266 cAdam           endif
1267 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1268 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1269 cga             do k=1,3
1270 cga               gg(k)=gg(k)*eps0ij
1271 cga             enddo
1272 cga             eps0ij=-evdwij*eps0ij
1273 C Uncomment for AL's type of SC correlation interactions.
1274 cadam           eps0ij=-evdwij
1275                 num_conti=num_conti+1
1276                 jcont(num_conti,i)=j
1277                 facont(num_conti,i)=fcont*eps0ij
1278                 fprimcont=eps0ij*fprimcont/rij
1279                 fcont=expon*fcont
1280 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1281 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1282 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1283 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1284                 gacont(1,num_conti,i)=-fprimcont*xj
1285                 gacont(2,num_conti,i)=-fprimcont*yj
1286                 gacont(3,num_conti,i)=-fprimcont*zj
1287 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1288 cd              write (iout,'(2i3,3f10.5)')
1289 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1290               endif
1291             endif
1292           enddo      ! j
1293         enddo        ! iint
1294 C Change 12/1/95
1295         num_cont(i)=num_conti
1296       enddo          ! i
1297       do i=1,nct
1298         do j=1,3
1299           gvdwc(j,i)=expon*gvdwc(j,i)
1300           gvdwx(j,i)=expon*gvdwx(j,i)
1301         enddo
1302       enddo
1303 C******************************************************************************
1304 C
1305 C                              N O T E !!!
1306 C
1307 C To save time, the factor of EXPON has been extracted from ALL components
1308 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1309 C use!
1310 C
1311 C******************************************************************************
1312       return
1313       end
1314 C-----------------------------------------------------------------------------
1315       subroutine eljk(evdw,evdw_p,evdw_m)
1316 C
1317 C This subroutine calculates the interaction energy of nonbonded side chains
1318 C assuming the LJK potential of interaction.
1319 C
1320       implicit real*8 (a-h,o-z)
1321       include 'DIMENSIONS'
1322       include 'COMMON.GEO'
1323       include 'COMMON.VAR'
1324       include 'COMMON.LOCAL'
1325       include 'COMMON.CHAIN'
1326       include 'COMMON.DERIV'
1327       include 'COMMON.INTERACT'
1328       include 'COMMON.IOUNITS'
1329       include 'COMMON.NAMES'
1330       dimension gg(3)
1331       logical scheck
1332 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1333       evdw=0.0D0
1334       do i=iatsc_s,iatsc_e
1335         itypi=itype(i)
1336         itypi1=itype(i+1)
1337         xi=c(1,nres+i)
1338         yi=c(2,nres+i)
1339         zi=c(3,nres+i)
1340 C
1341 C Calculate SC interaction energy.
1342 C
1343         do iint=1,nint_gr(i)
1344           do j=istart(i,iint),iend(i,iint)
1345             itypj=itype(j)
1346             xj=c(1,nres+j)-xi
1347             yj=c(2,nres+j)-yi
1348             zj=c(3,nres+j)-zi
1349             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1350             fac_augm=rrij**expon
1351             e_augm=augm(itypi,itypj)*fac_augm
1352             r_inv_ij=dsqrt(rrij)
1353             rij=1.0D0/r_inv_ij
1354             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1355             fac=r_shift_inv**expon
1356             e1=fac*fac*aa(itypi,itypj)
1357             e2=fac*bb(itypi,itypj)
1358             evdwij=e_augm+e1+e2
1359 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1360 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1361 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1362 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1363 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1364 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1365 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1366 #ifdef TSCSC
1367             if (bb(itypi,itypj).gt.0) then
1368                evdw_p=evdw_p+evdwij
1369             else
1370                evdw_m=evdw_m+evdwij
1371             endif
1372 #else
1373             evdw=evdw+evdwij
1374 #endif
1375 C
1376 C Calculate the components of the gradient in DC and X
1377 C
1378             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1379             gg(1)=xj*fac
1380             gg(2)=yj*fac
1381             gg(3)=zj*fac
1382 #ifdef TSCSC
1383             if (bb(itypi,itypj).gt.0.0d0) then
1384               do k=1,3
1385                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1386                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1387                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1388                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1389               enddo
1390             else
1391               do k=1,3
1392                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1393                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1394                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1395                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1396               enddo
1397             endif
1398 #else
1399             do k=1,3
1400               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1401               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1402               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1403               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1404             enddo
1405 #endif
1406 cgrad            do k=i,j-1
1407 cgrad              do l=1,3
1408 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1409 cgrad              enddo
1410 cgrad            enddo
1411           enddo      ! j
1412         enddo        ! iint
1413       enddo          ! i
1414       do i=1,nct
1415         do j=1,3
1416           gvdwc(j,i)=expon*gvdwc(j,i)
1417           gvdwx(j,i)=expon*gvdwx(j,i)
1418         enddo
1419       enddo
1420       return
1421       end
1422 C-----------------------------------------------------------------------------
1423       subroutine ebp(evdw,evdw_p,evdw_m)
1424 C
1425 C This subroutine calculates the interaction energy of nonbonded side chains
1426 C assuming the Berne-Pechukas potential of interaction.
1427 C
1428       implicit real*8 (a-h,o-z)
1429       include 'DIMENSIONS'
1430       include 'COMMON.GEO'
1431       include 'COMMON.VAR'
1432       include 'COMMON.LOCAL'
1433       include 'COMMON.CHAIN'
1434       include 'COMMON.DERIV'
1435       include 'COMMON.NAMES'
1436       include 'COMMON.INTERACT'
1437       include 'COMMON.IOUNITS'
1438       include 'COMMON.CALC'
1439       common /srutu/ icall
1440 c     double precision rrsave(maxdim)
1441       logical lprn
1442       evdw=0.0D0
1443 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1444       evdw=0.0D0
1445 c     if (icall.eq.0) then
1446 c       lprn=.true.
1447 c     else
1448         lprn=.false.
1449 c     endif
1450       ind=0
1451       do i=iatsc_s,iatsc_e
1452         itypi=itype(i)
1453         itypi1=itype(i+1)
1454         xi=c(1,nres+i)
1455         yi=c(2,nres+i)
1456         zi=c(3,nres+i)
1457         dxi=dc_norm(1,nres+i)
1458         dyi=dc_norm(2,nres+i)
1459         dzi=dc_norm(3,nres+i)
1460 c        dsci_inv=dsc_inv(itypi)
1461         dsci_inv=vbld_inv(i+nres)
1462 C
1463 C Calculate SC interaction energy.
1464 C
1465         do iint=1,nint_gr(i)
1466           do j=istart(i,iint),iend(i,iint)
1467             ind=ind+1
1468             itypj=itype(j)
1469 c            dscj_inv=dsc_inv(itypj)
1470             dscj_inv=vbld_inv(j+nres)
1471             chi1=chi(itypi,itypj)
1472             chi2=chi(itypj,itypi)
1473             chi12=chi1*chi2
1474             chip1=chip(itypi)
1475             chip2=chip(itypj)
1476             chip12=chip1*chip2
1477             alf1=alp(itypi)
1478             alf2=alp(itypj)
1479             alf12=0.5D0*(alf1+alf2)
1480 C For diagnostics only!!!
1481 c           chi1=0.0D0
1482 c           chi2=0.0D0
1483 c           chi12=0.0D0
1484 c           chip1=0.0D0
1485 c           chip2=0.0D0
1486 c           chip12=0.0D0
1487 c           alf1=0.0D0
1488 c           alf2=0.0D0
1489 c           alf12=0.0D0
1490             xj=c(1,nres+j)-xi
1491             yj=c(2,nres+j)-yi
1492             zj=c(3,nres+j)-zi
1493             dxj=dc_norm(1,nres+j)
1494             dyj=dc_norm(2,nres+j)
1495             dzj=dc_norm(3,nres+j)
1496             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1497 cd          if (icall.eq.0) then
1498 cd            rrsave(ind)=rrij
1499 cd          else
1500 cd            rrij=rrsave(ind)
1501 cd          endif
1502             rij=dsqrt(rrij)
1503 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1504             call sc_angular
1505 C Calculate whole angle-dependent part of epsilon and contributions
1506 C to its derivatives
1507             fac=(rrij*sigsq)**expon2
1508             e1=fac*fac*aa(itypi,itypj)
1509             e2=fac*bb(itypi,itypj)
1510             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1511             eps2der=evdwij*eps3rt
1512             eps3der=evdwij*eps2rt
1513             evdwij=evdwij*eps2rt*eps3rt
1514 #ifdef TSCSC
1515             if (bb(itypi,itypj).gt.0) then
1516                evdw_p=evdw_p+evdwij
1517             else
1518                evdw_m=evdw_m+evdwij
1519             endif
1520 #else
1521             evdw=evdw+evdwij
1522 #endif
1523             if (lprn) then
1524             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1525             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1526 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1527 cd     &        restyp(itypi),i,restyp(itypj),j,
1528 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1529 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1530 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1531 cd     &        evdwij
1532             endif
1533 C Calculate gradient components.
1534             e1=e1*eps1*eps2rt**2*eps3rt**2
1535             fac=-expon*(e1+evdwij)
1536             sigder=fac/sigsq
1537             fac=rrij*fac
1538 C Calculate radial part of the gradient
1539             gg(1)=xj*fac
1540             gg(2)=yj*fac
1541             gg(3)=zj*fac
1542 C Calculate the angular part of the gradient and sum add the contributions
1543 C to the appropriate components of the Cartesian gradient.
1544 #ifdef TSCSC
1545             if (bb(itypi,itypj).gt.0) then
1546                call sc_grad
1547             else
1548                call sc_grad_T
1549             endif
1550 #else
1551             call sc_grad
1552 #endif
1553           enddo      ! j
1554         enddo        ! iint
1555       enddo          ! i
1556 c     stop
1557       return
1558       end
1559 C-----------------------------------------------------------------------------
1560       subroutine egb(evdw,evdw_p,evdw_m)
1561 C
1562 C This subroutine calculates the interaction energy of nonbonded side chains
1563 C assuming the Gay-Berne potential of interaction.
1564 C
1565       implicit real*8 (a-h,o-z)
1566       include 'DIMENSIONS'
1567       include 'COMMON.GEO'
1568       include 'COMMON.VAR'
1569       include 'COMMON.LOCAL'
1570       include 'COMMON.CHAIN'
1571       include 'COMMON.DERIV'
1572       include 'COMMON.NAMES'
1573       include 'COMMON.INTERACT'
1574       include 'COMMON.IOUNITS'
1575       include 'COMMON.CALC'
1576       include 'COMMON.CONTROL'
1577       include 'COMMON.SBRIDGE'
1578       logical lprn
1579       evdw=0.0D0
1580 ccccc      energy_dec=.false.
1581 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1582       evdw=0.0D0
1583       evdw_p=0.0D0
1584       evdw_m=0.0D0
1585       lprn=.false.
1586 c     if (icall.eq.0) lprn=.false.
1587       ind=0
1588       do i=iatsc_s,iatsc_e
1589         itypi=itype(i)
1590         itypi1=itype(i+1)
1591         xi=c(1,nres+i)
1592         yi=c(2,nres+i)
1593         zi=c(3,nres+i)
1594         dxi=dc_norm(1,nres+i)
1595         dyi=dc_norm(2,nres+i)
1596         dzi=dc_norm(3,nres+i)
1597 c        dsci_inv=dsc_inv(itypi)
1598         dsci_inv=vbld_inv(i+nres)
1599 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1600 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1601 C
1602 C Calculate SC interaction energy.
1603 C
1604         do iint=1,nint_gr(i)
1605           do j=istart(i,iint),iend(i,iint)
1606             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1607               call dyn_ssbond_ene(i,j,evdwij)
1608               evdw=evdw+evdwij
1609               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1610      &                        'evdw',i,j,evdwij,' ss'
1611             ELSE
1612             ind=ind+1
1613             itypj=itype(j)
1614 c            dscj_inv=dsc_inv(itypj)
1615             dscj_inv=vbld_inv(j+nres)
1616 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1617 c     &       1.0d0/vbld(j+nres)
1618 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1619             sig0ij=sigma(itypi,itypj)
1620             chi1=chi(itypi,itypj)
1621             chi2=chi(itypj,itypi)
1622             chi12=chi1*chi2
1623             chip1=chip(itypi)
1624             chip2=chip(itypj)
1625             chip12=chip1*chip2
1626             alf1=alp(itypi)
1627             alf2=alp(itypj)
1628             alf12=0.5D0*(alf1+alf2)
1629 C For diagnostics only!!!
1630 c           chi1=0.0D0
1631 c           chi2=0.0D0
1632 c           chi12=0.0D0
1633 c           chip1=0.0D0
1634 c           chip2=0.0D0
1635 c           chip12=0.0D0
1636 c           alf1=0.0D0
1637 c           alf2=0.0D0
1638 c           alf12=0.0D0
1639             xj=c(1,nres+j)-xi
1640             yj=c(2,nres+j)-yi
1641             zj=c(3,nres+j)-zi
1642             dxj=dc_norm(1,nres+j)
1643             dyj=dc_norm(2,nres+j)
1644             dzj=dc_norm(3,nres+j)
1645 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1646 c            write (iout,*) "j",j," dc_norm",
1647 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1648             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1649             rij=dsqrt(rrij)
1650 C Calculate angle-dependent terms of energy and contributions to their
1651 C derivatives.
1652             call sc_angular
1653             sigsq=1.0D0/sigsq
1654             sig=sig0ij*dsqrt(sigsq)
1655             rij_shift=1.0D0/rij-sig+sig0ij
1656 c for diagnostics; uncomment
1657 c            rij_shift=1.2*sig0ij
1658 C I hate to put IF's in the loops, but here don't have another choice!!!!
1659             if (rij_shift.le.0.0D0) then
1660               evdw=1.0D20
1661 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1662 cd     &        restyp(itypi),i,restyp(itypj),j,
1663 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1664               return
1665             endif
1666             sigder=-sig*sigsq
1667 c---------------------------------------------------------------
1668             rij_shift=1.0D0/rij_shift
1669             fac=rij_shift**expon
1670             e1=fac*fac*aa(itypi,itypj)
1671             e2=fac*bb(itypi,itypj)
1672             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1673             eps2der=evdwij*eps3rt
1674             eps3der=evdwij*eps2rt
1675 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1676 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1677             evdwij=evdwij*eps2rt*eps3rt
1678 #ifdef TSCSC
1679             if (bb(itypi,itypj).gt.0) then
1680                evdw_p=evdw_p+evdwij
1681             else
1682                evdw_m=evdw_m+evdwij
1683             endif
1684 #else
1685             evdw=evdw+evdwij
1686 #endif
1687             if (lprn) then
1688             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1689             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1690             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1691      &        restyp(itypi),i,restyp(itypj),j,
1692      &        epsi,sigm,chi1,chi2,chip1,chip2,
1693      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1694      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1695      &        evdwij
1696             endif
1697
1698             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1699      &                        'evdw',i,j,evdwij
1700
1701 C Calculate gradient components.
1702             e1=e1*eps1*eps2rt**2*eps3rt**2
1703             fac=-expon*(e1+evdwij)*rij_shift
1704             sigder=fac*sigder
1705             fac=rij*fac
1706 c            fac=0.0d0
1707 C Calculate the radial part of the gradient
1708             gg(1)=xj*fac
1709             gg(2)=yj*fac
1710             gg(3)=zj*fac
1711 C Calculate angular part of the gradient.
1712 #ifdef TSCSC
1713             if (bb(itypi,itypj).gt.0) then
1714                call sc_grad
1715             else
1716                call sc_grad_T
1717             endif
1718 #else
1719             call sc_grad
1720 #endif
1721             ENDIF    ! dyn_ss
1722           enddo      ! j
1723         enddo        ! iint
1724       enddo          ! i
1725 c      write (iout,*) "Number of loop steps in EGB:",ind
1726 cccc      energy_dec=.false.
1727       return
1728       end
1729 C-----------------------------------------------------------------------------
1730       subroutine egbv(evdw,evdw_p,evdw_m)
1731 C
1732 C This subroutine calculates the interaction energy of nonbonded side chains
1733 C assuming the Gay-Berne-Vorobjev potential of interaction.
1734 C
1735       implicit real*8 (a-h,o-z)
1736       include 'DIMENSIONS'
1737       include 'COMMON.GEO'
1738       include 'COMMON.VAR'
1739       include 'COMMON.LOCAL'
1740       include 'COMMON.CHAIN'
1741       include 'COMMON.DERIV'
1742       include 'COMMON.NAMES'
1743       include 'COMMON.INTERACT'
1744       include 'COMMON.IOUNITS'
1745       include 'COMMON.CALC'
1746       common /srutu/ icall
1747       logical lprn
1748       evdw=0.0D0
1749 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1750       evdw=0.0D0
1751       lprn=.false.
1752 c     if (icall.eq.0) lprn=.true.
1753       ind=0
1754       do i=iatsc_s,iatsc_e
1755         itypi=itype(i)
1756         itypi1=itype(i+1)
1757         xi=c(1,nres+i)
1758         yi=c(2,nres+i)
1759         zi=c(3,nres+i)
1760         dxi=dc_norm(1,nres+i)
1761         dyi=dc_norm(2,nres+i)
1762         dzi=dc_norm(3,nres+i)
1763 c        dsci_inv=dsc_inv(itypi)
1764         dsci_inv=vbld_inv(i+nres)
1765 C
1766 C Calculate SC interaction energy.
1767 C
1768         do iint=1,nint_gr(i)
1769           do j=istart(i,iint),iend(i,iint)
1770             ind=ind+1
1771             itypj=itype(j)
1772 c            dscj_inv=dsc_inv(itypj)
1773             dscj_inv=vbld_inv(j+nres)
1774             sig0ij=sigma(itypi,itypj)
1775             r0ij=r0(itypi,itypj)
1776             chi1=chi(itypi,itypj)
1777             chi2=chi(itypj,itypi)
1778             chi12=chi1*chi2
1779             chip1=chip(itypi)
1780             chip2=chip(itypj)
1781             chip12=chip1*chip2
1782             alf1=alp(itypi)
1783             alf2=alp(itypj)
1784             alf12=0.5D0*(alf1+alf2)
1785 C For diagnostics only!!!
1786 c           chi1=0.0D0
1787 c           chi2=0.0D0
1788 c           chi12=0.0D0
1789 c           chip1=0.0D0
1790 c           chip2=0.0D0
1791 c           chip12=0.0D0
1792 c           alf1=0.0D0
1793 c           alf2=0.0D0
1794 c           alf12=0.0D0
1795             xj=c(1,nres+j)-xi
1796             yj=c(2,nres+j)-yi
1797             zj=c(3,nres+j)-zi
1798             dxj=dc_norm(1,nres+j)
1799             dyj=dc_norm(2,nres+j)
1800             dzj=dc_norm(3,nres+j)
1801             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1802             rij=dsqrt(rrij)
1803 C Calculate angle-dependent terms of energy and contributions to their
1804 C derivatives.
1805             call sc_angular
1806             sigsq=1.0D0/sigsq
1807             sig=sig0ij*dsqrt(sigsq)
1808             rij_shift=1.0D0/rij-sig+r0ij
1809 C I hate to put IF's in the loops, but here don't have another choice!!!!
1810             if (rij_shift.le.0.0D0) then
1811               evdw=1.0D20
1812               return
1813             endif
1814             sigder=-sig*sigsq
1815 c---------------------------------------------------------------
1816             rij_shift=1.0D0/rij_shift
1817             fac=rij_shift**expon
1818             e1=fac*fac*aa(itypi,itypj)
1819             e2=fac*bb(itypi,itypj)
1820             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1821             eps2der=evdwij*eps3rt
1822             eps3der=evdwij*eps2rt
1823             fac_augm=rrij**expon
1824             e_augm=augm(itypi,itypj)*fac_augm
1825             evdwij=evdwij*eps2rt*eps3rt
1826 #ifdef TSCSC
1827             if (bb(itypi,itypj).gt.0) then
1828                evdw_p=evdw_p+evdwij+e_augm
1829             else
1830                evdw_m=evdw_m+evdwij+e_augm
1831             endif
1832 #else
1833             evdw=evdw+evdwij+e_augm
1834 #endif
1835             if (lprn) then
1836             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1837             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1838             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1839      &        restyp(itypi),i,restyp(itypj),j,
1840      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1841      &        chi1,chi2,chip1,chip2,
1842      &        eps1,eps2rt**2,eps3rt**2,
1843      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1844      &        evdwij+e_augm
1845             endif
1846 C Calculate gradient components.
1847             e1=e1*eps1*eps2rt**2*eps3rt**2
1848             fac=-expon*(e1+evdwij)*rij_shift
1849             sigder=fac*sigder
1850             fac=rij*fac-2*expon*rrij*e_augm
1851 C Calculate the radial part of the gradient
1852             gg(1)=xj*fac
1853             gg(2)=yj*fac
1854             gg(3)=zj*fac
1855 C Calculate angular part of the gradient.
1856 #ifdef TSCSC
1857             if (bb(itypi,itypj).gt.0) then
1858                call sc_grad
1859             else
1860                call sc_grad_T
1861             endif
1862 #else
1863             call sc_grad
1864 #endif
1865           enddo      ! j
1866         enddo        ! iint
1867       enddo          ! i
1868       end
1869 C-----------------------------------------------------------------------------
1870       subroutine sc_angular
1871 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1872 C om12. Called by ebp, egb, and egbv.
1873       implicit none
1874       include 'COMMON.CALC'
1875       include 'COMMON.IOUNITS'
1876       erij(1)=xj*rij
1877       erij(2)=yj*rij
1878       erij(3)=zj*rij
1879       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1880       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1881       om12=dxi*dxj+dyi*dyj+dzi*dzj
1882       chiom12=chi12*om12
1883 C Calculate eps1(om12) and its derivative in om12
1884       faceps1=1.0D0-om12*chiom12
1885       faceps1_inv=1.0D0/faceps1
1886       eps1=dsqrt(faceps1_inv)
1887 C Following variable is eps1*deps1/dom12
1888       eps1_om12=faceps1_inv*chiom12
1889 c diagnostics only
1890 c      faceps1_inv=om12
1891 c      eps1=om12
1892 c      eps1_om12=1.0d0
1893 c      write (iout,*) "om12",om12," eps1",eps1
1894 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1895 C and om12.
1896       om1om2=om1*om2
1897       chiom1=chi1*om1
1898       chiom2=chi2*om2
1899       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1900       sigsq=1.0D0-facsig*faceps1_inv
1901       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1902       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1903       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1904 c diagnostics only
1905 c      sigsq=1.0d0
1906 c      sigsq_om1=0.0d0
1907 c      sigsq_om2=0.0d0
1908 c      sigsq_om12=0.0d0
1909 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1910 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1911 c     &    " eps1",eps1
1912 C Calculate eps2 and its derivatives in om1, om2, and om12.
1913       chipom1=chip1*om1
1914       chipom2=chip2*om2
1915       chipom12=chip12*om12
1916       facp=1.0D0-om12*chipom12
1917       facp_inv=1.0D0/facp
1918       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1919 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1920 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1921 C Following variable is the square root of eps2
1922       eps2rt=1.0D0-facp1*facp_inv
1923 C Following three variables are the derivatives of the square root of eps
1924 C in om1, om2, and om12.
1925       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1926       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1927       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1928 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1929       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1930 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1931 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1932 c     &  " eps2rt_om12",eps2rt_om12
1933 C Calculate whole angle-dependent part of epsilon and contributions
1934 C to its derivatives
1935       return
1936       end
1937
1938 C----------------------------------------------------------------------------
1939       subroutine sc_grad_T
1940       implicit real*8 (a-h,o-z)
1941       include 'DIMENSIONS'
1942       include 'COMMON.CHAIN'
1943       include 'COMMON.DERIV'
1944       include 'COMMON.CALC'
1945       include 'COMMON.IOUNITS'
1946       double precision dcosom1(3),dcosom2(3)
1947       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1948       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1949       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1950      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1951 c diagnostics only
1952 c      eom1=0.0d0
1953 c      eom2=0.0d0
1954 c      eom12=evdwij*eps1_om12
1955 c end diagnostics
1956 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1957 c     &  " sigder",sigder
1958 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1959 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1960       do k=1,3
1961         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1962         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1963       enddo
1964       do k=1,3
1965         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1966       enddo
1967 c      write (iout,*) "gg",(gg(k),k=1,3)
1968       do k=1,3
1969         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1970      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1971      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1972         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1973      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1974      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1975 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1976 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1977 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1978 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1979       enddo
1980 C
1981 C Calculate the components of the gradient in DC and X
1982 C
1983 cgrad      do k=i,j-1
1984 cgrad        do l=1,3
1985 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1986 cgrad        enddo
1987 cgrad      enddo
1988       do l=1,3
1989         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1990         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1991       enddo
1992       return
1993       end
1994
1995 C----------------------------------------------------------------------------
1996       subroutine sc_grad
1997       implicit real*8 (a-h,o-z)
1998       include 'DIMENSIONS'
1999       include 'COMMON.CHAIN'
2000       include 'COMMON.DERIV'
2001       include 'COMMON.CALC'
2002       include 'COMMON.IOUNITS'
2003       double precision dcosom1(3),dcosom2(3)
2004       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2005       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2006       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2007      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2008 c diagnostics only
2009 c      eom1=0.0d0
2010 c      eom2=0.0d0
2011 c      eom12=evdwij*eps1_om12
2012 c end diagnostics
2013 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2014 c     &  " sigder",sigder
2015 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2016 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2017       do k=1,3
2018         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2019         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2020       enddo
2021       do k=1,3
2022         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2023       enddo
2024 c      write (iout,*) "gg",(gg(k),k=1,3)
2025       do k=1,3
2026         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2027      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2028      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2029         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2030      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2031      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2032 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2033 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2034 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2035 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2036       enddo
2037 C
2038 C Calculate the components of the gradient in DC and X
2039 C
2040 cgrad      do k=i,j-1
2041 cgrad        do l=1,3
2042 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2043 cgrad        enddo
2044 cgrad      enddo
2045       do l=1,3
2046         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2047         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2048       enddo
2049       return
2050       end
2051 C-----------------------------------------------------------------------
2052       subroutine e_softsphere(evdw)
2053 C
2054 C This subroutine calculates the interaction energy of nonbonded side chains
2055 C assuming the LJ potential of interaction.
2056 C
2057       implicit real*8 (a-h,o-z)
2058       include 'DIMENSIONS'
2059       parameter (accur=1.0d-10)
2060       include 'COMMON.GEO'
2061       include 'COMMON.VAR'
2062       include 'COMMON.LOCAL'
2063       include 'COMMON.CHAIN'
2064       include 'COMMON.DERIV'
2065       include 'COMMON.INTERACT'
2066       include 'COMMON.TORSION'
2067       include 'COMMON.SBRIDGE'
2068       include 'COMMON.NAMES'
2069       include 'COMMON.IOUNITS'
2070       include 'COMMON.CONTACTS'
2071       dimension gg(3)
2072 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2073       evdw=0.0D0
2074       do i=iatsc_s,iatsc_e
2075         itypi=itype(i)
2076         itypi1=itype(i+1)
2077         xi=c(1,nres+i)
2078         yi=c(2,nres+i)
2079         zi=c(3,nres+i)
2080 C
2081 C Calculate SC interaction energy.
2082 C
2083         do iint=1,nint_gr(i)
2084 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2085 cd   &                  'iend=',iend(i,iint)
2086           do j=istart(i,iint),iend(i,iint)
2087             itypj=itype(j)
2088             xj=c(1,nres+j)-xi
2089             yj=c(2,nres+j)-yi
2090             zj=c(3,nres+j)-zi
2091             rij=xj*xj+yj*yj+zj*zj
2092 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2093             r0ij=r0(itypi,itypj)
2094             r0ijsq=r0ij*r0ij
2095 c            print *,i,j,r0ij,dsqrt(rij)
2096             if (rij.lt.r0ijsq) then
2097               evdwij=0.25d0*(rij-r0ijsq)**2
2098               fac=rij-r0ijsq
2099             else
2100               evdwij=0.0d0
2101               fac=0.0d0
2102             endif
2103             evdw=evdw+evdwij
2104 C
2105 C Calculate the components of the gradient in DC and X
2106 C
2107             gg(1)=xj*fac
2108             gg(2)=yj*fac
2109             gg(3)=zj*fac
2110             do k=1,3
2111               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2112               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2113               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2114               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2115             enddo
2116 cgrad            do k=i,j-1
2117 cgrad              do l=1,3
2118 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2119 cgrad              enddo
2120 cgrad            enddo
2121           enddo ! j
2122         enddo ! iint
2123       enddo ! i
2124       return
2125       end
2126 C--------------------------------------------------------------------------
2127       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2128      &              eello_turn4)
2129 C
2130 C Soft-sphere potential of p-p interaction
2131 C
2132       implicit real*8 (a-h,o-z)
2133       include 'DIMENSIONS'
2134       include 'COMMON.CONTROL'
2135       include 'COMMON.IOUNITS'
2136       include 'COMMON.GEO'
2137       include 'COMMON.VAR'
2138       include 'COMMON.LOCAL'
2139       include 'COMMON.CHAIN'
2140       include 'COMMON.DERIV'
2141       include 'COMMON.INTERACT'
2142       include 'COMMON.CONTACTS'
2143       include 'COMMON.TORSION'
2144       include 'COMMON.VECTORS'
2145       include 'COMMON.FFIELD'
2146       dimension ggg(3)
2147 cd      write(iout,*) 'In EELEC_soft_sphere'
2148       ees=0.0D0
2149       evdw1=0.0D0
2150       eel_loc=0.0d0
2151       eello_turn3=0.0d0
2152       eello_turn4=0.0d0
2153       ind=0
2154       do i=iatel_s,iatel_e
2155         dxi=dc(1,i)
2156         dyi=dc(2,i)
2157         dzi=dc(3,i)
2158         xmedi=c(1,i)+0.5d0*dxi
2159         ymedi=c(2,i)+0.5d0*dyi
2160         zmedi=c(3,i)+0.5d0*dzi
2161         num_conti=0
2162 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2163         do j=ielstart(i),ielend(i)
2164           ind=ind+1
2165           iteli=itel(i)
2166           itelj=itel(j)
2167           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2168           r0ij=rpp(iteli,itelj)
2169           r0ijsq=r0ij*r0ij
2170           dxj=dc(1,j)
2171           dyj=dc(2,j)
2172           dzj=dc(3,j)
2173           xj=c(1,j)+0.5D0*dxj-xmedi
2174           yj=c(2,j)+0.5D0*dyj-ymedi
2175           zj=c(3,j)+0.5D0*dzj-zmedi
2176           rij=xj*xj+yj*yj+zj*zj
2177           if (rij.lt.r0ijsq) then
2178             evdw1ij=0.25d0*(rij-r0ijsq)**2
2179             fac=rij-r0ijsq
2180           else
2181             evdw1ij=0.0d0
2182             fac=0.0d0
2183           endif
2184           evdw1=evdw1+evdw1ij
2185 C
2186 C Calculate contributions to the Cartesian gradient.
2187 C
2188           ggg(1)=fac*xj
2189           ggg(2)=fac*yj
2190           ggg(3)=fac*zj
2191           do k=1,3
2192             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2193             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2194           enddo
2195 *
2196 * Loop over residues i+1 thru j-1.
2197 *
2198 cgrad          do k=i+1,j-1
2199 cgrad            do l=1,3
2200 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2201 cgrad            enddo
2202 cgrad          enddo
2203         enddo ! j
2204       enddo   ! i
2205 cgrad      do i=nnt,nct-1
2206 cgrad        do k=1,3
2207 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2208 cgrad        enddo
2209 cgrad        do j=i+1,nct-1
2210 cgrad          do k=1,3
2211 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2212 cgrad          enddo
2213 cgrad        enddo
2214 cgrad      enddo
2215       return
2216       end
2217 c------------------------------------------------------------------------------
2218       subroutine vec_and_deriv
2219       implicit real*8 (a-h,o-z)
2220       include 'DIMENSIONS'
2221 #ifdef MPI
2222       include 'mpif.h'
2223 #endif
2224       include 'COMMON.IOUNITS'
2225       include 'COMMON.GEO'
2226       include 'COMMON.VAR'
2227       include 'COMMON.LOCAL'
2228       include 'COMMON.CHAIN'
2229       include 'COMMON.VECTORS'
2230       include 'COMMON.SETUP'
2231       include 'COMMON.TIME1'
2232       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2233 C Compute the local reference systems. For reference system (i), the
2234 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2235 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2236 #ifdef PARVEC
2237       do i=ivec_start,ivec_end
2238 #else
2239       do i=1,nres-1
2240 #endif
2241           if (i.eq.nres-1) then
2242 C Case of the last full residue
2243 C Compute the Z-axis
2244             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2245             costh=dcos(pi-theta(nres))
2246             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2247             do k=1,3
2248               uz(k,i)=fac*uz(k,i)
2249             enddo
2250 C Compute the derivatives of uz
2251             uzder(1,1,1)= 0.0d0
2252             uzder(2,1,1)=-dc_norm(3,i-1)
2253             uzder(3,1,1)= dc_norm(2,i-1)
2254             uzder(1,2,1)= dc_norm(3,i-1)
2255             uzder(2,2,1)= 0.0d0
2256             uzder(3,2,1)=-dc_norm(1,i-1)
2257             uzder(1,3,1)=-dc_norm(2,i-1)
2258             uzder(2,3,1)= dc_norm(1,i-1)
2259             uzder(3,3,1)= 0.0d0
2260             uzder(1,1,2)= 0.0d0
2261             uzder(2,1,2)= dc_norm(3,i)
2262             uzder(3,1,2)=-dc_norm(2,i)
2263             uzder(1,2,2)=-dc_norm(3,i)
2264             uzder(2,2,2)= 0.0d0
2265             uzder(3,2,2)= dc_norm(1,i)
2266             uzder(1,3,2)= dc_norm(2,i)
2267             uzder(2,3,2)=-dc_norm(1,i)
2268             uzder(3,3,2)= 0.0d0
2269 C Compute the Y-axis
2270             facy=fac
2271             do k=1,3
2272               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2273             enddo
2274 C Compute the derivatives of uy
2275             do j=1,3
2276               do k=1,3
2277                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2278      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2279                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2280               enddo
2281               uyder(j,j,1)=uyder(j,j,1)-costh
2282               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2283             enddo
2284             do j=1,2
2285               do k=1,3
2286                 do l=1,3
2287                   uygrad(l,k,j,i)=uyder(l,k,j)
2288                   uzgrad(l,k,j,i)=uzder(l,k,j)
2289                 enddo
2290               enddo
2291             enddo
2292             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2293             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2294             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2295             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2296           else
2297 C Other residues
2298 C Compute the Z-axis
2299             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2300             costh=dcos(pi-theta(i+2))
2301             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2302             do k=1,3
2303               uz(k,i)=fac*uz(k,i)
2304             enddo
2305 C Compute the derivatives of uz
2306             uzder(1,1,1)= 0.0d0
2307             uzder(2,1,1)=-dc_norm(3,i+1)
2308             uzder(3,1,1)= dc_norm(2,i+1)
2309             uzder(1,2,1)= dc_norm(3,i+1)
2310             uzder(2,2,1)= 0.0d0
2311             uzder(3,2,1)=-dc_norm(1,i+1)
2312             uzder(1,3,1)=-dc_norm(2,i+1)
2313             uzder(2,3,1)= dc_norm(1,i+1)
2314             uzder(3,3,1)= 0.0d0
2315             uzder(1,1,2)= 0.0d0
2316             uzder(2,1,2)= dc_norm(3,i)
2317             uzder(3,1,2)=-dc_norm(2,i)
2318             uzder(1,2,2)=-dc_norm(3,i)
2319             uzder(2,2,2)= 0.0d0
2320             uzder(3,2,2)= dc_norm(1,i)
2321             uzder(1,3,2)= dc_norm(2,i)
2322             uzder(2,3,2)=-dc_norm(1,i)
2323             uzder(3,3,2)= 0.0d0
2324 C Compute the Y-axis
2325             facy=fac
2326             do k=1,3
2327               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2328             enddo
2329 C Compute the derivatives of uy
2330             do j=1,3
2331               do k=1,3
2332                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2333      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2334                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2335               enddo
2336               uyder(j,j,1)=uyder(j,j,1)-costh
2337               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2338             enddo
2339             do j=1,2
2340               do k=1,3
2341                 do l=1,3
2342                   uygrad(l,k,j,i)=uyder(l,k,j)
2343                   uzgrad(l,k,j,i)=uzder(l,k,j)
2344                 enddo
2345               enddo
2346             enddo
2347             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2348             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2349             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2350             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2351           endif
2352       enddo
2353       do i=1,nres-1
2354         vbld_inv_temp(1)=vbld_inv(i+1)
2355         if (i.lt.nres-1) then
2356           vbld_inv_temp(2)=vbld_inv(i+2)
2357           else
2358           vbld_inv_temp(2)=vbld_inv(i)
2359           endif
2360         do j=1,2
2361           do k=1,3
2362             do l=1,3
2363               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2364               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2365             enddo
2366           enddo
2367         enddo
2368       enddo
2369 #if defined(PARVEC) && defined(MPI)
2370       if (nfgtasks1.gt.1) then
2371         time00=MPI_Wtime()
2372 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2373 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2374 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2375         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2376      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2377      &   FG_COMM1,IERR)
2378         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2379      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2380      &   FG_COMM1,IERR)
2381         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2382      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2383      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2384         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2385      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2386      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2387         time_gather=time_gather+MPI_Wtime()-time00
2388       endif
2389 c      if (fg_rank.eq.0) then
2390 c        write (iout,*) "Arrays UY and UZ"
2391 c        do i=1,nres-1
2392 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2393 c     &     (uz(k,i),k=1,3)
2394 c        enddo
2395 c      endif
2396 #endif
2397       return
2398       end
2399 C-----------------------------------------------------------------------------
2400       subroutine check_vecgrad
2401       implicit real*8 (a-h,o-z)
2402       include 'DIMENSIONS'
2403       include 'COMMON.IOUNITS'
2404       include 'COMMON.GEO'
2405       include 'COMMON.VAR'
2406       include 'COMMON.LOCAL'
2407       include 'COMMON.CHAIN'
2408       include 'COMMON.VECTORS'
2409       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2410       dimension uyt(3,maxres),uzt(3,maxres)
2411       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2412       double precision delta /1.0d-7/
2413       call vec_and_deriv
2414 cd      do i=1,nres
2415 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2416 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2417 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2418 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2419 cd     &     (dc_norm(if90,i),if90=1,3)
2420 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2421 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2422 cd          write(iout,'(a)')
2423 cd      enddo
2424       do i=1,nres
2425         do j=1,2
2426           do k=1,3
2427             do l=1,3
2428               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2429               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2430             enddo
2431           enddo
2432         enddo
2433       enddo
2434       call vec_and_deriv
2435       do i=1,nres
2436         do j=1,3
2437           uyt(j,i)=uy(j,i)
2438           uzt(j,i)=uz(j,i)
2439         enddo
2440       enddo
2441       do i=1,nres
2442 cd        write (iout,*) 'i=',i
2443         do k=1,3
2444           erij(k)=dc_norm(k,i)
2445         enddo
2446         do j=1,3
2447           do k=1,3
2448             dc_norm(k,i)=erij(k)
2449           enddo
2450           dc_norm(j,i)=dc_norm(j,i)+delta
2451 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2452 c          do k=1,3
2453 c            dc_norm(k,i)=dc_norm(k,i)/fac
2454 c          enddo
2455 c          write (iout,*) (dc_norm(k,i),k=1,3)
2456 c          write (iout,*) (erij(k),k=1,3)
2457           call vec_and_deriv
2458           do k=1,3
2459             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2460             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2461             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2462             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2463           enddo
2464 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2465 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2466 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2467         enddo
2468         do k=1,3
2469           dc_norm(k,i)=erij(k)
2470         enddo
2471 cd        do k=1,3
2472 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2473 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2474 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2475 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2476 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2477 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2478 cd          write (iout,'(a)')
2479 cd        enddo
2480       enddo
2481       return
2482       end
2483 C--------------------------------------------------------------------------
2484       subroutine set_matrices
2485       implicit real*8 (a-h,o-z)
2486       include 'DIMENSIONS'
2487 #ifdef MPI
2488       include "mpif.h"
2489       include "COMMON.SETUP"
2490       integer IERR
2491       integer status(MPI_STATUS_SIZE)
2492 #endif
2493       include 'COMMON.IOUNITS'
2494       include 'COMMON.GEO'
2495       include 'COMMON.VAR'
2496       include 'COMMON.LOCAL'
2497       include 'COMMON.CHAIN'
2498       include 'COMMON.DERIV'
2499       include 'COMMON.INTERACT'
2500       include 'COMMON.CONTACTS'
2501       include 'COMMON.TORSION'
2502       include 'COMMON.VECTORS'
2503       include 'COMMON.FFIELD'
2504       double precision auxvec(2),auxmat(2,2)
2505 C
2506 C Compute the virtual-bond-torsional-angle dependent quantities needed
2507 C to calculate the el-loc multibody terms of various order.
2508 C
2509 #ifdef PARMAT
2510       do i=ivec_start+2,ivec_end+2
2511 #else
2512       do i=3,nres+1
2513 #endif
2514         if (i .lt. nres+1) then
2515           sin1=dsin(phi(i))
2516           cos1=dcos(phi(i))
2517           sintab(i-2)=sin1
2518           costab(i-2)=cos1
2519           obrot(1,i-2)=cos1
2520           obrot(2,i-2)=sin1
2521           sin2=dsin(2*phi(i))
2522           cos2=dcos(2*phi(i))
2523           sintab2(i-2)=sin2
2524           costab2(i-2)=cos2
2525           obrot2(1,i-2)=cos2
2526           obrot2(2,i-2)=sin2
2527           Ug(1,1,i-2)=-cos1
2528           Ug(1,2,i-2)=-sin1
2529           Ug(2,1,i-2)=-sin1
2530           Ug(2,2,i-2)= cos1
2531           Ug2(1,1,i-2)=-cos2
2532           Ug2(1,2,i-2)=-sin2
2533           Ug2(2,1,i-2)=-sin2
2534           Ug2(2,2,i-2)= cos2
2535         else
2536           costab(i-2)=1.0d0
2537           sintab(i-2)=0.0d0
2538           obrot(1,i-2)=1.0d0
2539           obrot(2,i-2)=0.0d0
2540           obrot2(1,i-2)=0.0d0
2541           obrot2(2,i-2)=0.0d0
2542           Ug(1,1,i-2)=1.0d0
2543           Ug(1,2,i-2)=0.0d0
2544           Ug(2,1,i-2)=0.0d0
2545           Ug(2,2,i-2)=1.0d0
2546           Ug2(1,1,i-2)=0.0d0
2547           Ug2(1,2,i-2)=0.0d0
2548           Ug2(2,1,i-2)=0.0d0
2549           Ug2(2,2,i-2)=0.0d0
2550         endif
2551         if (i .gt. 3 .and. i .lt. nres+1) then
2552           obrot_der(1,i-2)=-sin1
2553           obrot_der(2,i-2)= cos1
2554           Ugder(1,1,i-2)= sin1
2555           Ugder(1,2,i-2)=-cos1
2556           Ugder(2,1,i-2)=-cos1
2557           Ugder(2,2,i-2)=-sin1
2558           dwacos2=cos2+cos2
2559           dwasin2=sin2+sin2
2560           obrot2_der(1,i-2)=-dwasin2
2561           obrot2_der(2,i-2)= dwacos2
2562           Ug2der(1,1,i-2)= dwasin2
2563           Ug2der(1,2,i-2)=-dwacos2
2564           Ug2der(2,1,i-2)=-dwacos2
2565           Ug2der(2,2,i-2)=-dwasin2
2566         else
2567           obrot_der(1,i-2)=0.0d0
2568           obrot_der(2,i-2)=0.0d0
2569           Ugder(1,1,i-2)=0.0d0
2570           Ugder(1,2,i-2)=0.0d0
2571           Ugder(2,1,i-2)=0.0d0
2572           Ugder(2,2,i-2)=0.0d0
2573           obrot2_der(1,i-2)=0.0d0
2574           obrot2_der(2,i-2)=0.0d0
2575           Ug2der(1,1,i-2)=0.0d0
2576           Ug2der(1,2,i-2)=0.0d0
2577           Ug2der(2,1,i-2)=0.0d0
2578           Ug2der(2,2,i-2)=0.0d0
2579         endif
2580 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2581         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2582           iti = itortyp(itype(i-2))
2583         else
2584           iti=ntortyp+1
2585         endif
2586 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2587         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2588           iti1 = itortyp(itype(i-1))
2589         else
2590           iti1=ntortyp+1
2591         endif
2592 cd        write (iout,*) '*******i',i,' iti1',iti
2593 cd        write (iout,*) 'b1',b1(:,iti)
2594 cd        write (iout,*) 'b2',b2(:,iti)
2595 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2596 c        if (i .gt. iatel_s+2) then
2597         if (i .gt. nnt+2) then
2598           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2599           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2600           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2601      &    then
2602           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2603           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2604           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2605           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2606           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2607           endif
2608         else
2609           do k=1,2
2610             Ub2(k,i-2)=0.0d0
2611             Ctobr(k,i-2)=0.0d0
2612             Dtobr2(k,i-2)=0.0d0
2613             do l=1,2
2614               EUg(l,k,i-2)=0.0d0
2615               CUg(l,k,i-2)=0.0d0
2616               DUg(l,k,i-2)=0.0d0
2617               DtUg2(l,k,i-2)=0.0d0
2618             enddo
2619           enddo
2620         endif
2621         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2622         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2623         do k=1,2
2624           muder(k,i-2)=Ub2der(k,i-2)
2625         enddo
2626 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2627         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2628           iti1 = itortyp(itype(i-1))
2629         else
2630           iti1=ntortyp+1
2631         endif
2632         do k=1,2
2633           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2634         enddo
2635 cd        write (iout,*) 'mu ',mu(:,i-2)
2636 cd        write (iout,*) 'mu1',mu1(:,i-2)
2637 cd        write (iout,*) 'mu2',mu2(:,i-2)
2638         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2639      &  then
2640         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2641         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2642         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2643         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2644         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2645 C Vectors and matrices dependent on a single virtual-bond dihedral.
2646         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2647         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2648         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2649         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2650         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2651         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2652         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2653         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2654         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2655         endif
2656       enddo
2657 C Matrices dependent on two consecutive virtual-bond dihedrals.
2658 C The order of matrices is from left to right.
2659       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2660      &then
2661 c      do i=max0(ivec_start,2),ivec_end
2662       do i=2,nres-1
2663         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2664         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2665         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2666         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2667         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2668         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2669         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2670         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2671       enddo
2672       endif
2673 #if defined(MPI) && defined(PARMAT)
2674 #ifdef DEBUG
2675 c      if (fg_rank.eq.0) then
2676         write (iout,*) "Arrays UG and UGDER before GATHER"
2677         do i=1,nres-1
2678           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2679      &     ((ug(l,k,i),l=1,2),k=1,2),
2680      &     ((ugder(l,k,i),l=1,2),k=1,2)
2681         enddo
2682         write (iout,*) "Arrays UG2 and UG2DER"
2683         do i=1,nres-1
2684           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2685      &     ((ug2(l,k,i),l=1,2),k=1,2),
2686      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2687         enddo
2688         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2689         do i=1,nres-1
2690           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2691      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2692      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2693         enddo
2694         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2695         do i=1,nres-1
2696           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2697      &     costab(i),sintab(i),costab2(i),sintab2(i)
2698         enddo
2699         write (iout,*) "Array MUDER"
2700         do i=1,nres-1
2701           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2702         enddo
2703 c      endif
2704 #endif
2705       if (nfgtasks.gt.1) then
2706         time00=MPI_Wtime()
2707 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2708 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2709 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2710 #ifdef MATGATHER
2711         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2712      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2713      &   FG_COMM1,IERR)
2714         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2715      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2716      &   FG_COMM1,IERR)
2717         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2718      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2719      &   FG_COMM1,IERR)
2720         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2721      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2722      &   FG_COMM1,IERR)
2723         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2724      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2725      &   FG_COMM1,IERR)
2726         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2727      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2728      &   FG_COMM1,IERR)
2729         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2730      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2731      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2732         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2733      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2734      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2735         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2736      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2737      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2738         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2739      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2740      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2741         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2742      &  then
2743         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2744      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2745      &   FG_COMM1,IERR)
2746         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2747      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2748      &   FG_COMM1,IERR)
2749         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2750      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2751      &   FG_COMM1,IERR)
2752        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2753      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2754      &   FG_COMM1,IERR)
2755         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2756      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2757      &   FG_COMM1,IERR)
2758         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2759      &   ivec_count(fg_rank1),
2760      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2761      &   FG_COMM1,IERR)
2762         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2763      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2764      &   FG_COMM1,IERR)
2765         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2766      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2767      &   FG_COMM1,IERR)
2768         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2769      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2770      &   FG_COMM1,IERR)
2771         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2772      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2773      &   FG_COMM1,IERR)
2774         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2775      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2776      &   FG_COMM1,IERR)
2777         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2778      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2779      &   FG_COMM1,IERR)
2780         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2781      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2782      &   FG_COMM1,IERR)
2783         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2784      &   ivec_count(fg_rank1),
2785      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2786      &   FG_COMM1,IERR)
2787         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2788      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2789      &   FG_COMM1,IERR)
2790        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2791      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2792      &   FG_COMM1,IERR)
2793         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2794      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2795      &   FG_COMM1,IERR)
2796        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2797      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2798      &   FG_COMM1,IERR)
2799         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2800      &   ivec_count(fg_rank1),
2801      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2802      &   FG_COMM1,IERR)
2803         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2804      &   ivec_count(fg_rank1),
2805      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2806      &   FG_COMM1,IERR)
2807         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2808      &   ivec_count(fg_rank1),
2809      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2810      &   MPI_MAT2,FG_COMM1,IERR)
2811         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2812      &   ivec_count(fg_rank1),
2813      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2814      &   MPI_MAT2,FG_COMM1,IERR)
2815         endif
2816 #else
2817 c Passes matrix info through the ring
2818       isend=fg_rank1
2819       irecv=fg_rank1-1
2820       if (irecv.lt.0) irecv=nfgtasks1-1
2821       iprev=irecv
2822       inext=fg_rank1+1
2823       if (inext.ge.nfgtasks1) inext=0
2824       do i=1,nfgtasks1-1
2825 c        write (iout,*) "isend",isend," irecv",irecv
2826 c        call flush(iout)
2827         lensend=lentyp(isend)
2828         lenrecv=lentyp(irecv)
2829 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2830 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2831 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2832 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2833 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2834 c        write (iout,*) "Gather ROTAT1"
2835 c        call flush(iout)
2836 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2837 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2838 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2839 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2840 c        write (iout,*) "Gather ROTAT2"
2841 c        call flush(iout)
2842         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2843      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2844      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2845      &   iprev,4400+irecv,FG_COMM,status,IERR)
2846 c        write (iout,*) "Gather ROTAT_OLD"
2847 c        call flush(iout)
2848         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2849      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2850      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2851      &   iprev,5500+irecv,FG_COMM,status,IERR)
2852 c        write (iout,*) "Gather PRECOMP11"
2853 c        call flush(iout)
2854         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2855      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2856      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2857      &   iprev,6600+irecv,FG_COMM,status,IERR)
2858 c        write (iout,*) "Gather PRECOMP12"
2859 c        call flush(iout)
2860         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2861      &  then
2862         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2863      &   MPI_ROTAT2(lensend),inext,7700+isend,
2864      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2865      &   iprev,7700+irecv,FG_COMM,status,IERR)
2866 c        write (iout,*) "Gather PRECOMP21"
2867 c        call flush(iout)
2868         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2869      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2870      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2871      &   iprev,8800+irecv,FG_COMM,status,IERR)
2872 c        write (iout,*) "Gather PRECOMP22"
2873 c        call flush(iout)
2874         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2875      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2876      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2877      &   MPI_PRECOMP23(lenrecv),
2878      &   iprev,9900+irecv,FG_COMM,status,IERR)
2879 c        write (iout,*) "Gather PRECOMP23"
2880 c        call flush(iout)
2881         endif
2882         isend=irecv
2883         irecv=irecv-1
2884         if (irecv.lt.0) irecv=nfgtasks1-1
2885       enddo
2886 #endif
2887         time_gather=time_gather+MPI_Wtime()-time00
2888       endif
2889 #ifdef DEBUG
2890 c      if (fg_rank.eq.0) then
2891         write (iout,*) "Arrays UG and UGDER"
2892         do i=1,nres-1
2893           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2894      &     ((ug(l,k,i),l=1,2),k=1,2),
2895      &     ((ugder(l,k,i),l=1,2),k=1,2)
2896         enddo
2897         write (iout,*) "Arrays UG2 and UG2DER"
2898         do i=1,nres-1
2899           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2900      &     ((ug2(l,k,i),l=1,2),k=1,2),
2901      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2902         enddo
2903         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2904         do i=1,nres-1
2905           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2906      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2907      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2908         enddo
2909         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2910         do i=1,nres-1
2911           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2912      &     costab(i),sintab(i),costab2(i),sintab2(i)
2913         enddo
2914         write (iout,*) "Array MUDER"
2915         do i=1,nres-1
2916           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2917         enddo
2918 c      endif
2919 #endif
2920 #endif
2921 cd      do i=1,nres
2922 cd        iti = itortyp(itype(i))
2923 cd        write (iout,*) i
2924 cd        do j=1,2
2925 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2926 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2927 cd        enddo
2928 cd      enddo
2929       return
2930       end
2931 C--------------------------------------------------------------------------
2932       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2933 C
2934 C This subroutine calculates the average interaction energy and its gradient
2935 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2936 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2937 C The potential depends both on the distance of peptide-group centers and on
2938 C the orientation of the CA-CA virtual bonds.
2939 C
2940       implicit real*8 (a-h,o-z)
2941 #ifdef MPI
2942       include 'mpif.h'
2943 #endif
2944       include 'DIMENSIONS'
2945       include 'COMMON.CONTROL'
2946       include 'COMMON.SETUP'
2947       include 'COMMON.IOUNITS'
2948       include 'COMMON.GEO'
2949       include 'COMMON.VAR'
2950       include 'COMMON.LOCAL'
2951       include 'COMMON.CHAIN'
2952       include 'COMMON.DERIV'
2953       include 'COMMON.INTERACT'
2954       include 'COMMON.CONTACTS'
2955       include 'COMMON.TORSION'
2956       include 'COMMON.VECTORS'
2957       include 'COMMON.FFIELD'
2958       include 'COMMON.TIME1'
2959       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2960      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2961       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2962      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2963       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2964      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2965      &    num_conti,j1,j2
2966 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2967 #ifdef MOMENT
2968       double precision scal_el /1.0d0/
2969 #else
2970       double precision scal_el /0.5d0/
2971 #endif
2972 C 12/13/98
2973 C 13-go grudnia roku pamietnego...
2974       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2975      &                   0.0d0,1.0d0,0.0d0,
2976      &                   0.0d0,0.0d0,1.0d0/
2977 cd      write(iout,*) 'In EELEC'
2978 cd      do i=1,nloctyp
2979 cd        write(iout,*) 'Type',i
2980 cd        write(iout,*) 'B1',B1(:,i)
2981 cd        write(iout,*) 'B2',B2(:,i)
2982 cd        write(iout,*) 'CC',CC(:,:,i)
2983 cd        write(iout,*) 'DD',DD(:,:,i)
2984 cd        write(iout,*) 'EE',EE(:,:,i)
2985 cd      enddo
2986 cd      call check_vecgrad
2987 cd      stop
2988       if (icheckgrad.eq.1) then
2989         do i=1,nres-1
2990           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2991           do k=1,3
2992             dc_norm(k,i)=dc(k,i)*fac
2993           enddo
2994 c          write (iout,*) 'i',i,' fac',fac
2995         enddo
2996       endif
2997       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2998      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2999      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3000 c        call vec_and_deriv
3001 #ifdef TIMING
3002         time01=MPI_Wtime()
3003 #endif
3004         call set_matrices
3005 #ifdef TIMING
3006         time_mat=time_mat+MPI_Wtime()-time01
3007 #endif
3008       endif
3009 cd      do i=1,nres-1
3010 cd        write (iout,*) 'i=',i
3011 cd        do k=1,3
3012 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3013 cd        enddo
3014 cd        do k=1,3
3015 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3016 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3017 cd        enddo
3018 cd      enddo
3019       t_eelecij=0.0d0
3020       ees=0.0D0
3021       evdw1=0.0D0
3022       eel_loc=0.0d0
3023       eello_turn3=0.0d0
3024       eello_turn4=0.0d0
3025       ind=0
3026       do i=1,nres
3027         num_cont_hb(i)=0
3028       enddo
3029 cd      print '(a)','Enter EELEC'
3030 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3031       do i=1,nres
3032         gel_loc_loc(i)=0.0d0
3033         gcorr_loc(i)=0.0d0
3034       enddo
3035 c
3036 c
3037 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3038 C
3039 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3040 C
3041       do i=iturn3_start,iturn3_end
3042         dxi=dc(1,i)
3043         dyi=dc(2,i)
3044         dzi=dc(3,i)
3045         dx_normi=dc_norm(1,i)
3046         dy_normi=dc_norm(2,i)
3047         dz_normi=dc_norm(3,i)
3048         xmedi=c(1,i)+0.5d0*dxi
3049         ymedi=c(2,i)+0.5d0*dyi
3050         zmedi=c(3,i)+0.5d0*dzi
3051         num_conti=0
3052         call eelecij(i,i+2,ees,evdw1,eel_loc)
3053         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3054         num_cont_hb(i)=num_conti
3055       enddo
3056       do i=iturn4_start,iturn4_end
3057         dxi=dc(1,i)
3058         dyi=dc(2,i)
3059         dzi=dc(3,i)
3060         dx_normi=dc_norm(1,i)
3061         dy_normi=dc_norm(2,i)
3062         dz_normi=dc_norm(3,i)
3063         xmedi=c(1,i)+0.5d0*dxi
3064         ymedi=c(2,i)+0.5d0*dyi
3065         zmedi=c(3,i)+0.5d0*dzi
3066         num_conti=num_cont_hb(i)
3067         call eelecij(i,i+3,ees,evdw1,eel_loc)
3068         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3069         num_cont_hb(i)=num_conti
3070       enddo   ! i
3071 c
3072 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3073 c
3074       do i=iatel_s,iatel_e
3075         dxi=dc(1,i)
3076         dyi=dc(2,i)
3077         dzi=dc(3,i)
3078         dx_normi=dc_norm(1,i)
3079         dy_normi=dc_norm(2,i)
3080         dz_normi=dc_norm(3,i)
3081         xmedi=c(1,i)+0.5d0*dxi
3082         ymedi=c(2,i)+0.5d0*dyi
3083         zmedi=c(3,i)+0.5d0*dzi
3084 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3085         num_conti=num_cont_hb(i)
3086         do j=ielstart(i),ielend(i)
3087           call eelecij(i,j,ees,evdw1,eel_loc)
3088         enddo ! j
3089         num_cont_hb(i)=num_conti
3090       enddo   ! i
3091 c      write (iout,*) "Number of loop steps in EELEC:",ind
3092 cd      do i=1,nres
3093 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3094 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3095 cd      enddo
3096 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3097 ccc      eel_loc=eel_loc+eello_turn3
3098 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3099       return
3100       end
3101 C-------------------------------------------------------------------------------
3102       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3103       implicit real*8 (a-h,o-z)
3104       include 'DIMENSIONS'
3105 #ifdef MPI
3106       include "mpif.h"
3107 #endif
3108       include 'COMMON.CONTROL'
3109       include 'COMMON.IOUNITS'
3110       include 'COMMON.GEO'
3111       include 'COMMON.VAR'
3112       include 'COMMON.LOCAL'
3113       include 'COMMON.CHAIN'
3114       include 'COMMON.DERIV'
3115       include 'COMMON.INTERACT'
3116       include 'COMMON.CONTACTS'
3117       include 'COMMON.TORSION'
3118       include 'COMMON.VECTORS'
3119       include 'COMMON.FFIELD'
3120       include 'COMMON.TIME1'
3121       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3122      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3123       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3124      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3125       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3126      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3127      &    num_conti,j1,j2
3128 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3129 #ifdef MOMENT
3130       double precision scal_el /1.0d0/
3131 #else
3132       double precision scal_el /0.5d0/
3133 #endif
3134 C 12/13/98
3135 C 13-go grudnia roku pamietnego...
3136       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3137      &                   0.0d0,1.0d0,0.0d0,
3138      &                   0.0d0,0.0d0,1.0d0/
3139 c          time00=MPI_Wtime()
3140 cd      write (iout,*) "eelecij",i,j
3141 c          ind=ind+1
3142           iteli=itel(i)
3143           itelj=itel(j)
3144           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3145           aaa=app(iteli,itelj)
3146           bbb=bpp(iteli,itelj)
3147           ael6i=ael6(iteli,itelj)
3148           ael3i=ael3(iteli,itelj)
3149           dxj=dc(1,j)
3150           dyj=dc(2,j)
3151           dzj=dc(3,j)
3152           dx_normj=dc_norm(1,j)
3153           dy_normj=dc_norm(2,j)
3154           dz_normj=dc_norm(3,j)
3155           xj=c(1,j)+0.5D0*dxj-xmedi
3156           yj=c(2,j)+0.5D0*dyj-ymedi
3157           zj=c(3,j)+0.5D0*dzj-zmedi
3158           rij=xj*xj+yj*yj+zj*zj
3159           rrmij=1.0D0/rij
3160           rij=dsqrt(rij)
3161           rmij=1.0D0/rij
3162           r3ij=rrmij*rmij
3163           r6ij=r3ij*r3ij
3164           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3165           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3166           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3167           fac=cosa-3.0D0*cosb*cosg
3168           ev1=aaa*r6ij*r6ij
3169 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3170           if (j.eq.i+2) ev1=scal_el*ev1
3171           ev2=bbb*r6ij
3172           fac3=ael6i*r6ij
3173           fac4=ael3i*r3ij
3174           evdwij=ev1+ev2
3175           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3176           el2=fac4*fac
3177           eesij=el1+el2
3178 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3179           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3180           ees=ees+eesij
3181           evdw1=evdw1+evdwij
3182 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3183 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3184 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3185 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3186
3187           if (energy_dec) then
3188               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3189               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3190           endif
3191
3192 C
3193 C Calculate contributions to the Cartesian gradient.
3194 C
3195 #ifdef SPLITELE
3196           facvdw=-6*rrmij*(ev1+evdwij)
3197           facel=-3*rrmij*(el1+eesij)
3198           fac1=fac
3199           erij(1)=xj*rmij
3200           erij(2)=yj*rmij
3201           erij(3)=zj*rmij
3202 *
3203 * Radial derivatives. First process both termini of the fragment (i,j)
3204 *
3205           ggg(1)=facel*xj
3206           ggg(2)=facel*yj
3207           ggg(3)=facel*zj
3208 c          do k=1,3
3209 c            ghalf=0.5D0*ggg(k)
3210 c            gelc(k,i)=gelc(k,i)+ghalf
3211 c            gelc(k,j)=gelc(k,j)+ghalf
3212 c          enddo
3213 c 9/28/08 AL Gradient compotents will be summed only at the end
3214           do k=1,3
3215             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3216             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3217           enddo
3218 *
3219 * Loop over residues i+1 thru j-1.
3220 *
3221 cgrad          do k=i+1,j-1
3222 cgrad            do l=1,3
3223 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3224 cgrad            enddo
3225 cgrad          enddo
3226           ggg(1)=facvdw*xj
3227           ggg(2)=facvdw*yj
3228           ggg(3)=facvdw*zj
3229 c          do k=1,3
3230 c            ghalf=0.5D0*ggg(k)
3231 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3232 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3233 c          enddo
3234 c 9/28/08 AL Gradient compotents will be summed only at the end
3235           do k=1,3
3236             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3237             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3238           enddo
3239 *
3240 * Loop over residues i+1 thru j-1.
3241 *
3242 cgrad          do k=i+1,j-1
3243 cgrad            do l=1,3
3244 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3245 cgrad            enddo
3246 cgrad          enddo
3247 #else
3248           facvdw=ev1+evdwij
3249           facel=el1+eesij
3250           fac1=fac
3251           fac=-3*rrmij*(facvdw+facvdw+facel)
3252           erij(1)=xj*rmij
3253           erij(2)=yj*rmij
3254           erij(3)=zj*rmij
3255 *
3256 * Radial derivatives. First process both termini of the fragment (i,j)
3257 *
3258           ggg(1)=fac*xj
3259           ggg(2)=fac*yj
3260           ggg(3)=fac*zj
3261 c          do k=1,3
3262 c            ghalf=0.5D0*ggg(k)
3263 c            gelc(k,i)=gelc(k,i)+ghalf
3264 c            gelc(k,j)=gelc(k,j)+ghalf
3265 c          enddo
3266 c 9/28/08 AL Gradient compotents will be summed only at the end
3267           do k=1,3
3268             gelc_long(k,j)=gelc(k,j)+ggg(k)
3269             gelc_long(k,i)=gelc(k,i)-ggg(k)
3270           enddo
3271 *
3272 * Loop over residues i+1 thru j-1.
3273 *
3274 cgrad          do k=i+1,j-1
3275 cgrad            do l=1,3
3276 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3277 cgrad            enddo
3278 cgrad          enddo
3279 c 9/28/08 AL Gradient compotents will be summed only at the end
3280           ggg(1)=facvdw*xj
3281           ggg(2)=facvdw*yj
3282           ggg(3)=facvdw*zj
3283           do k=1,3
3284             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3285             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3286           enddo
3287 #endif
3288 *
3289 * Angular part
3290 *
3291           ecosa=2.0D0*fac3*fac1+fac4
3292           fac4=-3.0D0*fac4
3293           fac3=-6.0D0*fac3
3294           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3295           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3296           do k=1,3
3297             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3298             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3299           enddo
3300 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3301 cd   &          (dcosg(k),k=1,3)
3302           do k=1,3
3303             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3304           enddo
3305 c          do k=1,3
3306 c            ghalf=0.5D0*ggg(k)
3307 c            gelc(k,i)=gelc(k,i)+ghalf
3308 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3309 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3310 c            gelc(k,j)=gelc(k,j)+ghalf
3311 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3312 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3313 c          enddo
3314 cgrad          do k=i+1,j-1
3315 cgrad            do l=1,3
3316 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3317 cgrad            enddo
3318 cgrad          enddo
3319           do k=1,3
3320             gelc(k,i)=gelc(k,i)
3321      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3322      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3323             gelc(k,j)=gelc(k,j)
3324      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3325      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3326             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3327             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3328           enddo
3329           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3330      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3331      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3332 C
3333 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3334 C   energy of a peptide unit is assumed in the form of a second-order
3335 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3336 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3337 C   are computed for EVERY pair of non-contiguous peptide groups.
3338 C
3339           if (j.lt.nres-1) then
3340             j1=j+1
3341             j2=j-1
3342           else
3343             j1=j-1
3344             j2=j-2
3345           endif
3346           kkk=0
3347           do k=1,2
3348             do l=1,2
3349               kkk=kkk+1
3350               muij(kkk)=mu(k,i)*mu(l,j)
3351             enddo
3352           enddo
3353 cd         write (iout,*) 'EELEC: i',i,' j',j
3354 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3355 cd          write(iout,*) 'muij',muij
3356           ury=scalar(uy(1,i),erij)
3357           urz=scalar(uz(1,i),erij)
3358           vry=scalar(uy(1,j),erij)
3359           vrz=scalar(uz(1,j),erij)
3360           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3361           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3362           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3363           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3364           fac=dsqrt(-ael6i)*r3ij
3365           a22=a22*fac
3366           a23=a23*fac
3367           a32=a32*fac
3368           a33=a33*fac
3369 cd          write (iout,'(4i5,4f10.5)')
3370 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3371 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3372 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3373 cd     &      uy(:,j),uz(:,j)
3374 cd          write (iout,'(4f10.5)')
3375 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3376 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3377 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3378 cd           write (iout,'(9f10.5/)')
3379 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3380 C Derivatives of the elements of A in virtual-bond vectors
3381           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3382           do k=1,3
3383             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3384             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3385             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3386             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3387             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3388             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3389             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3390             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3391             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3392             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3393             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3394             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3395           enddo
3396 C Compute radial contributions to the gradient
3397           facr=-3.0d0*rrmij
3398           a22der=a22*facr
3399           a23der=a23*facr
3400           a32der=a32*facr
3401           a33der=a33*facr
3402           agg(1,1)=a22der*xj
3403           agg(2,1)=a22der*yj
3404           agg(3,1)=a22der*zj
3405           agg(1,2)=a23der*xj
3406           agg(2,2)=a23der*yj
3407           agg(3,2)=a23der*zj
3408           agg(1,3)=a32der*xj
3409           agg(2,3)=a32der*yj
3410           agg(3,3)=a32der*zj
3411           agg(1,4)=a33der*xj
3412           agg(2,4)=a33der*yj
3413           agg(3,4)=a33der*zj
3414 C Add the contributions coming from er
3415           fac3=-3.0d0*fac
3416           do k=1,3
3417             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3418             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3419             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3420             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3421           enddo
3422           do k=1,3
3423 C Derivatives in DC(i)
3424 cgrad            ghalf1=0.5d0*agg(k,1)
3425 cgrad            ghalf2=0.5d0*agg(k,2)
3426 cgrad            ghalf3=0.5d0*agg(k,3)
3427 cgrad            ghalf4=0.5d0*agg(k,4)
3428             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3429      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3430             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3431      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3432             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3433      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3434             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3435      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3436 C Derivatives in DC(i+1)
3437             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3438      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3439             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3440      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3441             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3442      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3443             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3444      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3445 C Derivatives in DC(j)
3446             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3447      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3448             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3449      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3450             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3451      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3452             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3453      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3454 C Derivatives in DC(j+1) or DC(nres-1)
3455             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3456      &      -3.0d0*vryg(k,3)*ury)
3457             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3458      &      -3.0d0*vrzg(k,3)*ury)
3459             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3460      &      -3.0d0*vryg(k,3)*urz)
3461             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3462      &      -3.0d0*vrzg(k,3)*urz)
3463 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3464 cgrad              do l=1,4
3465 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3466 cgrad              enddo
3467 cgrad            endif
3468           enddo
3469           acipa(1,1)=a22
3470           acipa(1,2)=a23
3471           acipa(2,1)=a32
3472           acipa(2,2)=a33
3473           a22=-a22
3474           a23=-a23
3475           do l=1,2
3476             do k=1,3
3477               agg(k,l)=-agg(k,l)
3478               aggi(k,l)=-aggi(k,l)
3479               aggi1(k,l)=-aggi1(k,l)
3480               aggj(k,l)=-aggj(k,l)
3481               aggj1(k,l)=-aggj1(k,l)
3482             enddo
3483           enddo
3484           if (j.lt.nres-1) then
3485             a22=-a22
3486             a32=-a32
3487             do l=1,3,2
3488               do k=1,3
3489                 agg(k,l)=-agg(k,l)
3490                 aggi(k,l)=-aggi(k,l)
3491                 aggi1(k,l)=-aggi1(k,l)
3492                 aggj(k,l)=-aggj(k,l)
3493                 aggj1(k,l)=-aggj1(k,l)
3494               enddo
3495             enddo
3496           else
3497             a22=-a22
3498             a23=-a23
3499             a32=-a32
3500             a33=-a33
3501             do l=1,4
3502               do k=1,3
3503                 agg(k,l)=-agg(k,l)
3504                 aggi(k,l)=-aggi(k,l)
3505                 aggi1(k,l)=-aggi1(k,l)
3506                 aggj(k,l)=-aggj(k,l)
3507                 aggj1(k,l)=-aggj1(k,l)
3508               enddo
3509             enddo
3510           endif
3511           ENDIF ! WCORR
3512           IF (wel_loc.gt.0.0d0) THEN
3513 C Contribution to the local-electrostatic energy coming from the i-j pair
3514           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3515      &     +a33*muij(4)
3516 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3517
3518           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3519      &            'eelloc',i,j,eel_loc_ij
3520
3521           eel_loc=eel_loc+eel_loc_ij
3522 C Partial derivatives in virtual-bond dihedral angles gamma
3523           if (i.gt.1)
3524      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3525      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3526      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3527           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3528      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3529      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3530 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3531           do l=1,3
3532             ggg(l)=agg(l,1)*muij(1)+
3533      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3534             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3535             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3536 cgrad            ghalf=0.5d0*ggg(l)
3537 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3538 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3539           enddo
3540 cgrad          do k=i+1,j2
3541 cgrad            do l=1,3
3542 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3543 cgrad            enddo
3544 cgrad          enddo
3545 C Remaining derivatives of eello
3546           do l=1,3
3547             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3548      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3549             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3550      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3551             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3552      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3553             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3554      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3555           enddo
3556           ENDIF
3557 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3558 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3559           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3560      &       .and. num_conti.le.maxconts) then
3561 c            write (iout,*) i,j," entered corr"
3562 C
3563 C Calculate the contact function. The ith column of the array JCONT will
3564 C contain the numbers of atoms that make contacts with the atom I (of numbers
3565 C greater than I). The arrays FACONT and GACONT will contain the values of
3566 C the contact function and its derivative.
3567 c           r0ij=1.02D0*rpp(iteli,itelj)
3568 c           r0ij=1.11D0*rpp(iteli,itelj)
3569             r0ij=2.20D0*rpp(iteli,itelj)
3570 c           r0ij=1.55D0*rpp(iteli,itelj)
3571             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3572             if (fcont.gt.0.0D0) then
3573               num_conti=num_conti+1
3574               if (num_conti.gt.maxconts) then
3575                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3576      &                         ' will skip next contacts for this conf.'
3577               else
3578                 jcont_hb(num_conti,i)=j
3579 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3580 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3581                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3582      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3583 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3584 C  terms.
3585                 d_cont(num_conti,i)=rij
3586 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3587 C     --- Electrostatic-interaction matrix ---
3588                 a_chuj(1,1,num_conti,i)=a22
3589                 a_chuj(1,2,num_conti,i)=a23
3590                 a_chuj(2,1,num_conti,i)=a32
3591                 a_chuj(2,2,num_conti,i)=a33
3592 C     --- Gradient of rij
3593                 do kkk=1,3
3594                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3595                 enddo
3596                 kkll=0
3597                 do k=1,2
3598                   do l=1,2
3599                     kkll=kkll+1
3600                     do m=1,3
3601                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3602                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3603                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3604                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3605                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3606                     enddo
3607                   enddo
3608                 enddo
3609                 ENDIF
3610                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3611 C Calculate contact energies
3612                 cosa4=4.0D0*cosa
3613                 wij=cosa-3.0D0*cosb*cosg
3614                 cosbg1=cosb+cosg
3615                 cosbg2=cosb-cosg
3616 c               fac3=dsqrt(-ael6i)/r0ij**3
3617                 fac3=dsqrt(-ael6i)*r3ij
3618 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3619                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3620                 if (ees0tmp.gt.0) then
3621                   ees0pij=dsqrt(ees0tmp)
3622                 else
3623                   ees0pij=0
3624                 endif
3625 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3626                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3627                 if (ees0tmp.gt.0) then
3628                   ees0mij=dsqrt(ees0tmp)
3629                 else
3630                   ees0mij=0
3631                 endif
3632 c               ees0mij=0.0D0
3633                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3634                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3635 C Diagnostics. Comment out or remove after debugging!
3636 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3637 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3638 c               ees0m(num_conti,i)=0.0D0
3639 C End diagnostics.
3640 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3641 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3642 C Angular derivatives of the contact function
3643                 ees0pij1=fac3/ees0pij
3644                 ees0mij1=fac3/ees0mij
3645                 fac3p=-3.0D0*fac3*rrmij
3646                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3647                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3648 c               ees0mij1=0.0D0
3649                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3650                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3651                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3652                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3653                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3654                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3655                 ecosap=ecosa1+ecosa2
3656                 ecosbp=ecosb1+ecosb2
3657                 ecosgp=ecosg1+ecosg2
3658                 ecosam=ecosa1-ecosa2
3659                 ecosbm=ecosb1-ecosb2
3660                 ecosgm=ecosg1-ecosg2
3661 C Diagnostics
3662 c               ecosap=ecosa1
3663 c               ecosbp=ecosb1
3664 c               ecosgp=ecosg1
3665 c               ecosam=0.0D0
3666 c               ecosbm=0.0D0
3667 c               ecosgm=0.0D0
3668 C End diagnostics
3669                 facont_hb(num_conti,i)=fcont
3670                 fprimcont=fprimcont/rij
3671 cd              facont_hb(num_conti,i)=1.0D0
3672 C Following line is for diagnostics.
3673 cd              fprimcont=0.0D0
3674                 do k=1,3
3675                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3676                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3677                 enddo
3678                 do k=1,3
3679                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3680                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3681                 enddo
3682                 gggp(1)=gggp(1)+ees0pijp*xj
3683                 gggp(2)=gggp(2)+ees0pijp*yj
3684                 gggp(3)=gggp(3)+ees0pijp*zj
3685                 gggm(1)=gggm(1)+ees0mijp*xj
3686                 gggm(2)=gggm(2)+ees0mijp*yj
3687                 gggm(3)=gggm(3)+ees0mijp*zj
3688 C Derivatives due to the contact function
3689                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3690                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3691                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3692                 do k=1,3
3693 c
3694 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3695 c          following the change of gradient-summation algorithm.
3696 c
3697 cgrad                  ghalfp=0.5D0*gggp(k)
3698 cgrad                  ghalfm=0.5D0*gggm(k)
3699                   gacontp_hb1(k,num_conti,i)=!ghalfp
3700      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3701      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3702                   gacontp_hb2(k,num_conti,i)=!ghalfp
3703      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3704      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3705                   gacontp_hb3(k,num_conti,i)=gggp(k)
3706                   gacontm_hb1(k,num_conti,i)=!ghalfm
3707      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3708      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3709                   gacontm_hb2(k,num_conti,i)=!ghalfm
3710      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3711      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3712                   gacontm_hb3(k,num_conti,i)=gggm(k)
3713                 enddo
3714 C Diagnostics. Comment out or remove after debugging!
3715 cdiag           do k=1,3
3716 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3717 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3718 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3719 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3720 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3721 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3722 cdiag           enddo
3723               ENDIF ! wcorr
3724               endif  ! num_conti.le.maxconts
3725             endif  ! fcont.gt.0
3726           endif    ! j.gt.i+1
3727           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3728             do k=1,4
3729               do l=1,3
3730                 ghalf=0.5d0*agg(l,k)
3731                 aggi(l,k)=aggi(l,k)+ghalf
3732                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3733                 aggj(l,k)=aggj(l,k)+ghalf
3734               enddo
3735             enddo
3736             if (j.eq.nres-1 .and. i.lt.j-2) then
3737               do k=1,4
3738                 do l=1,3
3739                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3740                 enddo
3741               enddo
3742             endif
3743           endif
3744 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3745       return
3746       end
3747 C-----------------------------------------------------------------------------
3748       subroutine eturn3(i,eello_turn3)
3749 C Third- and fourth-order contributions from turns
3750       implicit real*8 (a-h,o-z)
3751       include 'DIMENSIONS'
3752       include 'COMMON.IOUNITS'
3753       include 'COMMON.GEO'
3754       include 'COMMON.VAR'
3755       include 'COMMON.LOCAL'
3756       include 'COMMON.CHAIN'
3757       include 'COMMON.DERIV'
3758       include 'COMMON.INTERACT'
3759       include 'COMMON.CONTACTS'
3760       include 'COMMON.TORSION'
3761       include 'COMMON.VECTORS'
3762       include 'COMMON.FFIELD'
3763       include 'COMMON.CONTROL'
3764       dimension ggg(3)
3765       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3766      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3767      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3768       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3769      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3770       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3771      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3772      &    num_conti,j1,j2
3773       j=i+2
3774 c      write (iout,*) "eturn3",i,j,j1,j2
3775       a_temp(1,1)=a22
3776       a_temp(1,2)=a23
3777       a_temp(2,1)=a32
3778       a_temp(2,2)=a33
3779 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3780 C
3781 C               Third-order contributions
3782 C
3783 C                 (i+2)o----(i+3)
3784 C                      | |
3785 C                      | |
3786 C                 (i+1)o----i
3787 C
3788 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3789 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3790         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3791         call transpose2(auxmat(1,1),auxmat1(1,1))
3792         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3793         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3794         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3795      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3796 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3797 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3798 cd     &    ' eello_turn3_num',4*eello_turn3_num
3799 C Derivatives in gamma(i)
3800         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3801         call transpose2(auxmat2(1,1),auxmat3(1,1))
3802         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3803         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3804 C Derivatives in gamma(i+1)
3805         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3806         call transpose2(auxmat2(1,1),auxmat3(1,1))
3807         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3808         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3809      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3810 C Cartesian derivatives
3811         do l=1,3
3812 c            ghalf1=0.5d0*agg(l,1)
3813 c            ghalf2=0.5d0*agg(l,2)
3814 c            ghalf3=0.5d0*agg(l,3)
3815 c            ghalf4=0.5d0*agg(l,4)
3816           a_temp(1,1)=aggi(l,1)!+ghalf1
3817           a_temp(1,2)=aggi(l,2)!+ghalf2
3818           a_temp(2,1)=aggi(l,3)!+ghalf3
3819           a_temp(2,2)=aggi(l,4)!+ghalf4
3820           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3821           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3822      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3823           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3824           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3825           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3826           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3827           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3828           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3829      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3830           a_temp(1,1)=aggj(l,1)!+ghalf1
3831           a_temp(1,2)=aggj(l,2)!+ghalf2
3832           a_temp(2,1)=aggj(l,3)!+ghalf3
3833           a_temp(2,2)=aggj(l,4)!+ghalf4
3834           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3835           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3836      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3837           a_temp(1,1)=aggj1(l,1)
3838           a_temp(1,2)=aggj1(l,2)
3839           a_temp(2,1)=aggj1(l,3)
3840           a_temp(2,2)=aggj1(l,4)
3841           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3842           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3843      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3844         enddo
3845       return
3846       end
3847 C-------------------------------------------------------------------------------
3848       subroutine eturn4(i,eello_turn4)
3849 C Third- and fourth-order contributions from turns
3850       implicit real*8 (a-h,o-z)
3851       include 'DIMENSIONS'
3852       include 'COMMON.IOUNITS'
3853       include 'COMMON.GEO'
3854       include 'COMMON.VAR'
3855       include 'COMMON.LOCAL'
3856       include 'COMMON.CHAIN'
3857       include 'COMMON.DERIV'
3858       include 'COMMON.INTERACT'
3859       include 'COMMON.CONTACTS'
3860       include 'COMMON.TORSION'
3861       include 'COMMON.VECTORS'
3862       include 'COMMON.FFIELD'
3863       include 'COMMON.CONTROL'
3864       dimension ggg(3)
3865       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3866      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3867      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3868       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3869      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3870       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3871      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3872      &    num_conti,j1,j2
3873       j=i+3
3874 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3875 C
3876 C               Fourth-order contributions
3877 C
3878 C                 (i+3)o----(i+4)
3879 C                     /  |
3880 C               (i+2)o   |
3881 C                     \  |
3882 C                 (i+1)o----i
3883 C
3884 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3885 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3886 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3887         a_temp(1,1)=a22
3888         a_temp(1,2)=a23
3889         a_temp(2,1)=a32
3890         a_temp(2,2)=a33
3891         iti1=itortyp(itype(i+1))
3892         iti2=itortyp(itype(i+2))
3893         iti3=itortyp(itype(i+3))
3894 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3895         call transpose2(EUg(1,1,i+1),e1t(1,1))
3896         call transpose2(Eug(1,1,i+2),e2t(1,1))
3897         call transpose2(Eug(1,1,i+3),e3t(1,1))
3898         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3899         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3900         s1=scalar2(b1(1,iti2),auxvec(1))
3901         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3902         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3903         s2=scalar2(b1(1,iti1),auxvec(1))
3904         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3905         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3906         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3907         eello_turn4=eello_turn4-(s1+s2+s3)
3908         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3909      &      'eturn4',i,j,-(s1+s2+s3)
3910 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3911 cd     &    ' eello_turn4_num',8*eello_turn4_num
3912 C Derivatives in gamma(i)
3913         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3914         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3915         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3916         s1=scalar2(b1(1,iti2),auxvec(1))
3917         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3918         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3919         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3920 C Derivatives in gamma(i+1)
3921         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3922         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3923         s2=scalar2(b1(1,iti1),auxvec(1))
3924         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3925         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3926         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3927         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3928 C Derivatives in gamma(i+2)
3929         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3930         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3931         s1=scalar2(b1(1,iti2),auxvec(1))
3932         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3933         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3934         s2=scalar2(b1(1,iti1),auxvec(1))
3935         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3936         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3937         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3938         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3939 C Cartesian derivatives
3940 C Derivatives of this turn contributions in DC(i+2)
3941         if (j.lt.nres-1) then
3942           do l=1,3
3943             a_temp(1,1)=agg(l,1)
3944             a_temp(1,2)=agg(l,2)
3945             a_temp(2,1)=agg(l,3)
3946             a_temp(2,2)=agg(l,4)
3947             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3948             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3949             s1=scalar2(b1(1,iti2),auxvec(1))
3950             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3951             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3952             s2=scalar2(b1(1,iti1),auxvec(1))
3953             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3954             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3955             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3956             ggg(l)=-(s1+s2+s3)
3957             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3958           enddo
3959         endif
3960 C Remaining derivatives of this turn contribution
3961         do l=1,3
3962           a_temp(1,1)=aggi(l,1)
3963           a_temp(1,2)=aggi(l,2)
3964           a_temp(2,1)=aggi(l,3)
3965           a_temp(2,2)=aggi(l,4)
3966           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3967           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3968           s1=scalar2(b1(1,iti2),auxvec(1))
3969           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3970           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3971           s2=scalar2(b1(1,iti1),auxvec(1))
3972           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3973           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3974           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3975           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3976           a_temp(1,1)=aggi1(l,1)
3977           a_temp(1,2)=aggi1(l,2)
3978           a_temp(2,1)=aggi1(l,3)
3979           a_temp(2,2)=aggi1(l,4)
3980           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3981           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3982           s1=scalar2(b1(1,iti2),auxvec(1))
3983           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3984           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3985           s2=scalar2(b1(1,iti1),auxvec(1))
3986           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3987           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3988           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3989           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3990           a_temp(1,1)=aggj(l,1)
3991           a_temp(1,2)=aggj(l,2)
3992           a_temp(2,1)=aggj(l,3)
3993           a_temp(2,2)=aggj(l,4)
3994           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3995           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3996           s1=scalar2(b1(1,iti2),auxvec(1))
3997           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3998           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3999           s2=scalar2(b1(1,iti1),auxvec(1))
4000           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4001           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4002           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4003           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4004           a_temp(1,1)=aggj1(l,1)
4005           a_temp(1,2)=aggj1(l,2)
4006           a_temp(2,1)=aggj1(l,3)
4007           a_temp(2,2)=aggj1(l,4)
4008           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4009           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4010           s1=scalar2(b1(1,iti2),auxvec(1))
4011           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4012           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4013           s2=scalar2(b1(1,iti1),auxvec(1))
4014           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4015           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4016           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4017 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4018           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4019         enddo
4020       return
4021       end
4022 C-----------------------------------------------------------------------------
4023       subroutine vecpr(u,v,w)
4024       implicit real*8(a-h,o-z)
4025       dimension u(3),v(3),w(3)
4026       w(1)=u(2)*v(3)-u(3)*v(2)
4027       w(2)=-u(1)*v(3)+u(3)*v(1)
4028       w(3)=u(1)*v(2)-u(2)*v(1)
4029       return
4030       end
4031 C-----------------------------------------------------------------------------
4032       subroutine unormderiv(u,ugrad,unorm,ungrad)
4033 C This subroutine computes the derivatives of a normalized vector u, given
4034 C the derivatives computed without normalization conditions, ugrad. Returns
4035 C ungrad.
4036       implicit none
4037       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4038       double precision vec(3)
4039       double precision scalar
4040       integer i,j
4041 c      write (2,*) 'ugrad',ugrad
4042 c      write (2,*) 'u',u
4043       do i=1,3
4044         vec(i)=scalar(ugrad(1,i),u(1))
4045       enddo
4046 c      write (2,*) 'vec',vec
4047       do i=1,3
4048         do j=1,3
4049           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4050         enddo
4051       enddo
4052 c      write (2,*) 'ungrad',ungrad
4053       return
4054       end
4055 C-----------------------------------------------------------------------------
4056       subroutine escp_soft_sphere(evdw2,evdw2_14)
4057 C
4058 C This subroutine calculates the excluded-volume interaction energy between
4059 C peptide-group centers and side chains and its gradient in virtual-bond and
4060 C side-chain vectors.
4061 C
4062       implicit real*8 (a-h,o-z)
4063       include 'DIMENSIONS'
4064       include 'COMMON.GEO'
4065       include 'COMMON.VAR'
4066       include 'COMMON.LOCAL'
4067       include 'COMMON.CHAIN'
4068       include 'COMMON.DERIV'
4069       include 'COMMON.INTERACT'
4070       include 'COMMON.FFIELD'
4071       include 'COMMON.IOUNITS'
4072       include 'COMMON.CONTROL'
4073       dimension ggg(3)
4074       evdw2=0.0D0
4075       evdw2_14=0.0d0
4076       r0_scp=4.5d0
4077 cd    print '(a)','Enter ESCP'
4078 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4079       do i=iatscp_s,iatscp_e
4080         iteli=itel(i)
4081         xi=0.5D0*(c(1,i)+c(1,i+1))
4082         yi=0.5D0*(c(2,i)+c(2,i+1))
4083         zi=0.5D0*(c(3,i)+c(3,i+1))
4084
4085         do iint=1,nscp_gr(i)
4086
4087         do j=iscpstart(i,iint),iscpend(i,iint)
4088           itypj=itype(j)
4089 C Uncomment following three lines for SC-p interactions
4090 c         xj=c(1,nres+j)-xi
4091 c         yj=c(2,nres+j)-yi
4092 c         zj=c(3,nres+j)-zi
4093 C Uncomment following three lines for Ca-p interactions
4094           xj=c(1,j)-xi
4095           yj=c(2,j)-yi
4096           zj=c(3,j)-zi
4097           rij=xj*xj+yj*yj+zj*zj
4098           r0ij=r0_scp
4099           r0ijsq=r0ij*r0ij
4100           if (rij.lt.r0ijsq) then
4101             evdwij=0.25d0*(rij-r0ijsq)**2
4102             fac=rij-r0ijsq
4103           else
4104             evdwij=0.0d0
4105             fac=0.0d0
4106           endif
4107           evdw2=evdw2+evdwij
4108 C
4109 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4110 C
4111           ggg(1)=xj*fac
4112           ggg(2)=yj*fac
4113           ggg(3)=zj*fac
4114 cgrad          if (j.lt.i) then
4115 cd          write (iout,*) 'j<i'
4116 C Uncomment following three lines for SC-p interactions
4117 c           do k=1,3
4118 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4119 c           enddo
4120 cgrad          else
4121 cd          write (iout,*) 'j>i'
4122 cgrad            do k=1,3
4123 cgrad              ggg(k)=-ggg(k)
4124 C Uncomment following line for SC-p interactions
4125 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4126 cgrad            enddo
4127 cgrad          endif
4128 cgrad          do k=1,3
4129 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4130 cgrad          enddo
4131 cgrad          kstart=min0(i+1,j)
4132 cgrad          kend=max0(i-1,j-1)
4133 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4134 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4135 cgrad          do k=kstart,kend
4136 cgrad            do l=1,3
4137 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4138 cgrad            enddo
4139 cgrad          enddo
4140           do k=1,3
4141             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4142             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4143           enddo
4144         enddo
4145
4146         enddo ! iint
4147       enddo ! i
4148       return
4149       end
4150 C-----------------------------------------------------------------------------
4151       subroutine escp(evdw2,evdw2_14)
4152 C
4153 C This subroutine calculates the excluded-volume interaction energy between
4154 C peptide-group centers and side chains and its gradient in virtual-bond and
4155 C side-chain vectors.
4156 C
4157       implicit real*8 (a-h,o-z)
4158       include 'DIMENSIONS'
4159       include 'COMMON.GEO'
4160       include 'COMMON.VAR'
4161       include 'COMMON.LOCAL'
4162       include 'COMMON.CHAIN'
4163       include 'COMMON.DERIV'
4164       include 'COMMON.INTERACT'
4165       include 'COMMON.FFIELD'
4166       include 'COMMON.IOUNITS'
4167       include 'COMMON.CONTROL'
4168       dimension ggg(3)
4169       evdw2=0.0D0
4170       evdw2_14=0.0d0
4171 cd    print '(a)','Enter ESCP'
4172 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4173       do i=iatscp_s,iatscp_e
4174         iteli=itel(i)
4175         xi=0.5D0*(c(1,i)+c(1,i+1))
4176         yi=0.5D0*(c(2,i)+c(2,i+1))
4177         zi=0.5D0*(c(3,i)+c(3,i+1))
4178
4179         do iint=1,nscp_gr(i)
4180
4181         do j=iscpstart(i,iint),iscpend(i,iint)
4182           itypj=itype(j)
4183 C Uncomment following three lines for SC-p interactions
4184 c         xj=c(1,nres+j)-xi
4185 c         yj=c(2,nres+j)-yi
4186 c         zj=c(3,nres+j)-zi
4187 C Uncomment following three lines for Ca-p interactions
4188           xj=c(1,j)-xi
4189           yj=c(2,j)-yi
4190           zj=c(3,j)-zi
4191           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4192           fac=rrij**expon2
4193           e1=fac*fac*aad(itypj,iteli)
4194           e2=fac*bad(itypj,iteli)
4195           if (iabs(j-i) .le. 2) then
4196             e1=scal14*e1
4197             e2=scal14*e2
4198             evdw2_14=evdw2_14+e1+e2
4199           endif
4200           evdwij=e1+e2
4201           evdw2=evdw2+evdwij
4202           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4203      &        'evdw2',i,j,evdwij
4204 C
4205 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4206 C
4207           fac=-(evdwij+e1)*rrij
4208           ggg(1)=xj*fac
4209           ggg(2)=yj*fac
4210           ggg(3)=zj*fac
4211 cgrad          if (j.lt.i) then
4212 cd          write (iout,*) 'j<i'
4213 C Uncomment following three lines for SC-p interactions
4214 c           do k=1,3
4215 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4216 c           enddo
4217 cgrad          else
4218 cd          write (iout,*) 'j>i'
4219 cgrad            do k=1,3
4220 cgrad              ggg(k)=-ggg(k)
4221 C Uncomment following line for SC-p interactions
4222 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4223 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4224 cgrad            enddo
4225 cgrad          endif
4226 cgrad          do k=1,3
4227 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4228 cgrad          enddo
4229 cgrad          kstart=min0(i+1,j)
4230 cgrad          kend=max0(i-1,j-1)
4231 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4232 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4233 cgrad          do k=kstart,kend
4234 cgrad            do l=1,3
4235 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4236 cgrad            enddo
4237 cgrad          enddo
4238           do k=1,3
4239             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4240             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4241           enddo
4242         enddo
4243
4244         enddo ! iint
4245       enddo ! i
4246       do i=1,nct
4247         do j=1,3
4248           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4249           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4250           gradx_scp(j,i)=expon*gradx_scp(j,i)
4251         enddo
4252       enddo
4253 C******************************************************************************
4254 C
4255 C                              N O T E !!!
4256 C
4257 C To save time the factor EXPON has been extracted from ALL components
4258 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4259 C use!
4260 C
4261 C******************************************************************************
4262       return
4263       end
4264 C--------------------------------------------------------------------------
4265       subroutine edis(ehpb)
4266 C
4267 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4268 C
4269       implicit real*8 (a-h,o-z)
4270       include 'DIMENSIONS'
4271       include 'COMMON.SBRIDGE'
4272       include 'COMMON.CHAIN'
4273       include 'COMMON.DERIV'
4274       include 'COMMON.VAR'
4275       include 'COMMON.INTERACT'
4276       include 'COMMON.IOUNITS'
4277       dimension ggg(3)
4278       ehpb=0.0D0
4279 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4280 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4281       if (link_end.eq.0) return
4282       do i=link_start,link_end
4283 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4284 C CA-CA distance used in regularization of structure.
4285         ii=ihpb(i)
4286         jj=jhpb(i)
4287 C iii and jjj point to the residues for which the distance is assigned.
4288         if (ii.gt.nres) then
4289           iii=ii-nres
4290           jjj=jj-nres
4291         else
4292           iii=ii
4293           jjj=jj
4294         endif
4295 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4296 c     &    dhpb(i),dhpb1(i),forcon(i)
4297 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4298 C    distance and angle dependent SS bond potential.
4299 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4300 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4301         if (.not.dyn_ss .and. i.le.nss) then
4302 C 15/02/13 CC dynamic SSbond - additional check
4303          if (ii.gt.nres
4304      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4305           call ssbond_ene(iii,jjj,eij)
4306           ehpb=ehpb+2*eij
4307          endif
4308 cd          write (iout,*) "eij",eij
4309         else if (ii.gt.nres .and. jj.gt.nres) then
4310 c Restraints from contact prediction
4311           dd=dist(ii,jj)
4312           if (dhpb1(i).gt.0.0d0) then
4313             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4314             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4315 c            write (iout,*) "beta nmr",
4316 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4317           else
4318             dd=dist(ii,jj)
4319             rdis=dd-dhpb(i)
4320 C Get the force constant corresponding to this distance.
4321             waga=forcon(i)
4322 C Calculate the contribution to energy.
4323             ehpb=ehpb+waga*rdis*rdis
4324 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4325 C
4326 C Evaluate gradient.
4327 C
4328             fac=waga*rdis/dd
4329           endif
4330           do j=1,3
4331             ggg(j)=fac*(c(j,jj)-c(j,ii))
4332           enddo
4333           do j=1,3
4334             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4335             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4336           enddo
4337           do k=1,3
4338             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4339             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4340           enddo
4341         else
4342 C Calculate the distance between the two points and its difference from the
4343 C target distance.
4344           dd=dist(ii,jj)
4345           if (dhpb1(i).gt.0.0d0) then
4346             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4347             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4348 c            write (iout,*) "alph nmr",
4349 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4350           else
4351             rdis=dd-dhpb(i)
4352 C Get the force constant corresponding to this distance.
4353             waga=forcon(i)
4354 C Calculate the contribution to energy.
4355             ehpb=ehpb+waga*rdis*rdis
4356 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4357 C
4358 C Evaluate gradient.
4359 C
4360             fac=waga*rdis/dd
4361           endif
4362 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4363 cd   &   ' waga=',waga,' fac=',fac
4364             do j=1,3
4365               ggg(j)=fac*(c(j,jj)-c(j,ii))
4366             enddo
4367 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4368 C If this is a SC-SC distance, we need to calculate the contributions to the
4369 C Cartesian gradient in the SC vectors (ghpbx).
4370           if (iii.lt.ii) then
4371           do j=1,3
4372             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4373             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4374           enddo
4375           endif
4376 cgrad        do j=iii,jjj-1
4377 cgrad          do k=1,3
4378 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4379 cgrad          enddo
4380 cgrad        enddo
4381           do k=1,3
4382             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4383             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4384           enddo
4385         endif
4386       enddo
4387       ehpb=0.5D0*ehpb
4388       return
4389       end
4390 C--------------------------------------------------------------------------
4391       subroutine ssbond_ene(i,j,eij)
4392 C
4393 C Calculate the distance and angle dependent SS-bond potential energy
4394 C using a free-energy function derived based on RHF/6-31G** ab initio
4395 C calculations of diethyl disulfide.
4396 C
4397 C A. Liwo and U. Kozlowska, 11/24/03
4398 C
4399       implicit real*8 (a-h,o-z)
4400       include 'DIMENSIONS'
4401       include 'COMMON.SBRIDGE'
4402       include 'COMMON.CHAIN'
4403       include 'COMMON.DERIV'
4404       include 'COMMON.LOCAL'
4405       include 'COMMON.INTERACT'
4406       include 'COMMON.VAR'
4407       include 'COMMON.IOUNITS'
4408       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4409       itypi=itype(i)
4410       xi=c(1,nres+i)
4411       yi=c(2,nres+i)
4412       zi=c(3,nres+i)
4413       dxi=dc_norm(1,nres+i)
4414       dyi=dc_norm(2,nres+i)
4415       dzi=dc_norm(3,nres+i)
4416 c      dsci_inv=dsc_inv(itypi)
4417       dsci_inv=vbld_inv(nres+i)
4418       itypj=itype(j)
4419 c      dscj_inv=dsc_inv(itypj)
4420       dscj_inv=vbld_inv(nres+j)
4421       xj=c(1,nres+j)-xi
4422       yj=c(2,nres+j)-yi
4423       zj=c(3,nres+j)-zi
4424       dxj=dc_norm(1,nres+j)
4425       dyj=dc_norm(2,nres+j)
4426       dzj=dc_norm(3,nres+j)
4427       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4428       rij=dsqrt(rrij)
4429       erij(1)=xj*rij
4430       erij(2)=yj*rij
4431       erij(3)=zj*rij
4432       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4433       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4434       om12=dxi*dxj+dyi*dyj+dzi*dzj
4435       do k=1,3
4436         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4437         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4438       enddo
4439       rij=1.0d0/rij
4440       deltad=rij-d0cm
4441       deltat1=1.0d0-om1
4442       deltat2=1.0d0+om2
4443       deltat12=om2-om1+2.0d0
4444       cosphi=om12-om1*om2
4445       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4446      &  +akct*deltad*deltat12+ebr
4447      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4448 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4449 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4450 c     &  " deltat12",deltat12," eij",eij
4451       ed=2*akcm*deltad+akct*deltat12
4452       pom1=akct*deltad
4453       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4454       eom1=-2*akth*deltat1-pom1-om2*pom2
4455       eom2= 2*akth*deltat2+pom1-om1*pom2
4456       eom12=pom2
4457       do k=1,3
4458         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4459         ghpbx(k,i)=ghpbx(k,i)-ggk
4460      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4461      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4462         ghpbx(k,j)=ghpbx(k,j)+ggk
4463      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4464      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4465         ghpbc(k,i)=ghpbc(k,i)-ggk
4466         ghpbc(k,j)=ghpbc(k,j)+ggk
4467       enddo
4468 C
4469 C Calculate the components of the gradient in DC and X
4470 C
4471 cgrad      do k=i,j-1
4472 cgrad        do l=1,3
4473 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4474 cgrad        enddo
4475 cgrad      enddo
4476       return
4477       end
4478 C--------------------------------------------------------------------------
4479       subroutine ebond(estr)
4480 c
4481 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4482 c
4483       implicit real*8 (a-h,o-z)
4484       include 'DIMENSIONS'
4485       include 'COMMON.LOCAL'
4486       include 'COMMON.GEO'
4487       include 'COMMON.INTERACT'
4488       include 'COMMON.DERIV'
4489       include 'COMMON.VAR'
4490       include 'COMMON.CHAIN'
4491       include 'COMMON.IOUNITS'
4492       include 'COMMON.NAMES'
4493       include 'COMMON.FFIELD'
4494       include 'COMMON.CONTROL'
4495       include 'COMMON.SETUP'
4496       double precision u(3),ud(3)
4497       estr=0.0d0
4498       do i=ibondp_start,ibondp_end
4499         diff = vbld(i)-vbldp0
4500 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4501         estr=estr+diff*diff
4502         do j=1,3
4503           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4504         enddo
4505 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4506       enddo
4507       estr=0.5d0*AKP*estr
4508 c
4509 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4510 c
4511       do i=ibond_start,ibond_end
4512         iti=itype(i)
4513         if (iti.ne.10) then
4514           nbi=nbondterm(iti)
4515           if (nbi.eq.1) then
4516             diff=vbld(i+nres)-vbldsc0(1,iti)
4517 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4518 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4519             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4520             do j=1,3
4521               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4522             enddo
4523           else
4524             do j=1,nbi
4525               diff=vbld(i+nres)-vbldsc0(j,iti)
4526               ud(j)=aksc(j,iti)*diff
4527               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4528             enddo
4529             uprod=u(1)
4530             do j=2,nbi
4531               uprod=uprod*u(j)
4532             enddo
4533             usum=0.0d0
4534             usumsqder=0.0d0
4535             do j=1,nbi
4536               uprod1=1.0d0
4537               uprod2=1.0d0
4538               do k=1,nbi
4539                 if (k.ne.j) then
4540                   uprod1=uprod1*u(k)
4541                   uprod2=uprod2*u(k)*u(k)
4542                 endif
4543               enddo
4544               usum=usum+uprod1
4545               usumsqder=usumsqder+ud(j)*uprod2
4546             enddo
4547             estr=estr+uprod/usum
4548             do j=1,3
4549              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4550             enddo
4551           endif
4552         endif
4553       enddo
4554       return
4555       end
4556 #ifdef CRYST_THETA
4557 C--------------------------------------------------------------------------
4558       subroutine ebend(etheta)
4559 C
4560 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4561 C angles gamma and its derivatives in consecutive thetas and gammas.
4562 C
4563       implicit real*8 (a-h,o-z)
4564       include 'DIMENSIONS'
4565       include 'COMMON.LOCAL'
4566       include 'COMMON.GEO'
4567       include 'COMMON.INTERACT'
4568       include 'COMMON.DERIV'
4569       include 'COMMON.VAR'
4570       include 'COMMON.CHAIN'
4571       include 'COMMON.IOUNITS'
4572       include 'COMMON.NAMES'
4573       include 'COMMON.FFIELD'
4574       include 'COMMON.CONTROL'
4575       common /calcthet/ term1,term2,termm,diffak,ratak,
4576      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4577      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4578       double precision y(2),z(2)
4579       delta=0.02d0*pi
4580 c      time11=dexp(-2*time)
4581 c      time12=1.0d0
4582       etheta=0.0D0
4583 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4584       do i=ithet_start,ithet_end
4585 C Zero the energy function and its derivative at 0 or pi.
4586         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4587         it=itype(i-1)
4588         if (i.gt.3) then
4589 #ifdef OSF
4590           phii=phi(i)
4591           if (phii.ne.phii) phii=150.0
4592 #else
4593           phii=phi(i)
4594 #endif
4595           y(1)=dcos(phii)
4596           y(2)=dsin(phii)
4597         else
4598           y(1)=0.0D0
4599           y(2)=0.0D0
4600         endif
4601         if (i.lt.nres) then
4602 #ifdef OSF
4603           phii1=phi(i+1)
4604           if (phii1.ne.phii1) phii1=150.0
4605           phii1=pinorm(phii1)
4606           z(1)=cos(phii1)
4607 #else
4608           phii1=phi(i+1)
4609           z(1)=dcos(phii1)
4610 #endif
4611           z(2)=dsin(phii1)
4612         else
4613           z(1)=0.0D0
4614           z(2)=0.0D0
4615         endif
4616 C Calculate the "mean" value of theta from the part of the distribution
4617 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4618 C In following comments this theta will be referred to as t_c.
4619         thet_pred_mean=0.0d0
4620         do k=1,2
4621           athetk=athet(k,it)
4622           bthetk=bthet(k,it)
4623           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4624         enddo
4625         dthett=thet_pred_mean*ssd
4626         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4627 C Derivatives of the "mean" values in gamma1 and gamma2.
4628         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4629         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4630         if (theta(i).gt.pi-delta) then
4631           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4632      &         E_tc0)
4633           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4634           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4635           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4636      &        E_theta)
4637           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4638      &        E_tc)
4639         else if (theta(i).lt.delta) then
4640           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4641           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4642           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4643      &        E_theta)
4644           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4645           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4646      &        E_tc)
4647         else
4648           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4649      &        E_theta,E_tc)
4650         endif
4651         etheta=etheta+ethetai
4652         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4653      &      'ebend',i,ethetai
4654         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4655         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4656         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4657       enddo
4658 C Ufff.... We've done all this!!!
4659       return
4660       end
4661 C---------------------------------------------------------------------------
4662       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4663      &     E_tc)
4664       implicit real*8 (a-h,o-z)
4665       include 'DIMENSIONS'
4666       include 'COMMON.LOCAL'
4667       include 'COMMON.IOUNITS'
4668       common /calcthet/ term1,term2,termm,diffak,ratak,
4669      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4670      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4671 C Calculate the contributions to both Gaussian lobes.
4672 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4673 C The "polynomial part" of the "standard deviation" of this part of
4674 C the distribution.
4675         sig=polthet(3,it)
4676         do j=2,0,-1
4677           sig=sig*thet_pred_mean+polthet(j,it)
4678         enddo
4679 C Derivative of the "interior part" of the "standard deviation of the"
4680 C gamma-dependent Gaussian lobe in t_c.
4681         sigtc=3*polthet(3,it)
4682         do j=2,1,-1
4683           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4684         enddo
4685         sigtc=sig*sigtc
4686 C Set the parameters of both Gaussian lobes of the distribution.
4687 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4688         fac=sig*sig+sigc0(it)
4689         sigcsq=fac+fac
4690         sigc=1.0D0/sigcsq
4691 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4692         sigsqtc=-4.0D0*sigcsq*sigtc
4693 c       print *,i,sig,sigtc,sigsqtc
4694 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4695         sigtc=-sigtc/(fac*fac)
4696 C Following variable is sigma(t_c)**(-2)
4697         sigcsq=sigcsq*sigcsq
4698         sig0i=sig0(it)
4699         sig0inv=1.0D0/sig0i**2
4700         delthec=thetai-thet_pred_mean
4701         delthe0=thetai-theta0i
4702         term1=-0.5D0*sigcsq*delthec*delthec
4703         term2=-0.5D0*sig0inv*delthe0*delthe0
4704 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4705 C NaNs in taking the logarithm. We extract the largest exponent which is added
4706 C to the energy (this being the log of the distribution) at the end of energy
4707 C term evaluation for this virtual-bond angle.
4708         if (term1.gt.term2) then
4709           termm=term1
4710           term2=dexp(term2-termm)
4711           term1=1.0d0
4712         else
4713           termm=term2
4714           term1=dexp(term1-termm)
4715           term2=1.0d0
4716         endif
4717 C The ratio between the gamma-independent and gamma-dependent lobes of
4718 C the distribution is a Gaussian function of thet_pred_mean too.
4719         diffak=gthet(2,it)-thet_pred_mean
4720         ratak=diffak/gthet(3,it)**2
4721         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4722 C Let's differentiate it in thet_pred_mean NOW.
4723         aktc=ak*ratak
4724 C Now put together the distribution terms to make complete distribution.
4725         termexp=term1+ak*term2
4726         termpre=sigc+ak*sig0i
4727 C Contribution of the bending energy from this theta is just the -log of
4728 C the sum of the contributions from the two lobes and the pre-exponential
4729 C factor. Simple enough, isn't it?
4730         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4731 C NOW the derivatives!!!
4732 C 6/6/97 Take into account the deformation.
4733         E_theta=(delthec*sigcsq*term1
4734      &       +ak*delthe0*sig0inv*term2)/termexp
4735         E_tc=((sigtc+aktc*sig0i)/termpre
4736      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4737      &       aktc*term2)/termexp)
4738       return
4739       end
4740 c-----------------------------------------------------------------------------
4741       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4742       implicit real*8 (a-h,o-z)
4743       include 'DIMENSIONS'
4744       include 'COMMON.LOCAL'
4745       include 'COMMON.IOUNITS'
4746       common /calcthet/ term1,term2,termm,diffak,ratak,
4747      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4748      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4749       delthec=thetai-thet_pred_mean
4750       delthe0=thetai-theta0i
4751 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4752       t3 = thetai-thet_pred_mean
4753       t6 = t3**2
4754       t9 = term1
4755       t12 = t3*sigcsq
4756       t14 = t12+t6*sigsqtc
4757       t16 = 1.0d0
4758       t21 = thetai-theta0i
4759       t23 = t21**2
4760       t26 = term2
4761       t27 = t21*t26
4762       t32 = termexp
4763       t40 = t32**2
4764       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4765      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4766      & *(-t12*t9-ak*sig0inv*t27)
4767       return
4768       end
4769 #else
4770 C--------------------------------------------------------------------------
4771       subroutine ebend(etheta)
4772 C
4773 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4774 C angles gamma and its derivatives in consecutive thetas and gammas.
4775 C ab initio-derived potentials from
4776 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4777 C
4778       implicit real*8 (a-h,o-z)
4779       include 'DIMENSIONS'
4780       include 'COMMON.LOCAL'
4781       include 'COMMON.GEO'
4782       include 'COMMON.INTERACT'
4783       include 'COMMON.DERIV'
4784       include 'COMMON.VAR'
4785       include 'COMMON.CHAIN'
4786       include 'COMMON.IOUNITS'
4787       include 'COMMON.NAMES'
4788       include 'COMMON.FFIELD'
4789       include 'COMMON.CONTROL'
4790       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4791      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4792      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4793      & sinph1ph2(maxdouble,maxdouble)
4794       logical lprn /.false./, lprn1 /.false./
4795       etheta=0.0D0
4796       do i=ithet_start,ithet_end
4797         dethetai=0.0d0
4798         dephii=0.0d0
4799         dephii1=0.0d0
4800         theti2=0.5d0*theta(i)
4801         ityp2=ithetyp(itype(i-1))
4802         do k=1,nntheterm
4803           coskt(k)=dcos(k*theti2)
4804           sinkt(k)=dsin(k*theti2)
4805         enddo
4806         if (i.gt.3) then
4807 #ifdef OSF
4808           phii=phi(i)
4809           if (phii.ne.phii) phii=150.0
4810 #else
4811           phii=phi(i)
4812 #endif
4813           ityp1=ithetyp(itype(i-2))
4814           do k=1,nsingle
4815             cosph1(k)=dcos(k*phii)
4816             sinph1(k)=dsin(k*phii)
4817           enddo
4818         else
4819           phii=0.0d0
4820           ityp1=nthetyp+1
4821           do k=1,nsingle
4822             cosph1(k)=0.0d0
4823             sinph1(k)=0.0d0
4824           enddo
4825         endif
4826         if (i.lt.nres) then
4827 #ifdef OSF
4828           phii1=phi(i+1)
4829           if (phii1.ne.phii1) phii1=150.0
4830           phii1=pinorm(phii1)
4831 #else
4832           phii1=phi(i+1)
4833 #endif
4834           ityp3=ithetyp(itype(i))
4835           do k=1,nsingle
4836             cosph2(k)=dcos(k*phii1)
4837             sinph2(k)=dsin(k*phii1)
4838           enddo
4839         else
4840           phii1=0.0d0
4841           ityp3=nthetyp+1
4842           do k=1,nsingle
4843             cosph2(k)=0.0d0
4844             sinph2(k)=0.0d0
4845           enddo
4846         endif
4847         ethetai=aa0thet(ityp1,ityp2,ityp3)
4848         do k=1,ndouble
4849           do l=1,k-1
4850             ccl=cosph1(l)*cosph2(k-l)
4851             ssl=sinph1(l)*sinph2(k-l)
4852             scl=sinph1(l)*cosph2(k-l)
4853             csl=cosph1(l)*sinph2(k-l)
4854             cosph1ph2(l,k)=ccl-ssl
4855             cosph1ph2(k,l)=ccl+ssl
4856             sinph1ph2(l,k)=scl+csl
4857             sinph1ph2(k,l)=scl-csl
4858           enddo
4859         enddo
4860         if (lprn) then
4861         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4862      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4863         write (iout,*) "coskt and sinkt"
4864         do k=1,nntheterm
4865           write (iout,*) k,coskt(k),sinkt(k)
4866         enddo
4867         endif
4868         do k=1,ntheterm
4869           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4870           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4871      &      *coskt(k)
4872           if (lprn)
4873      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4874      &     " ethetai",ethetai
4875         enddo
4876         if (lprn) then
4877         write (iout,*) "cosph and sinph"
4878         do k=1,nsingle
4879           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4880         enddo
4881         write (iout,*) "cosph1ph2 and sinph2ph2"
4882         do k=2,ndouble
4883           do l=1,k-1
4884             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4885      &         sinph1ph2(l,k),sinph1ph2(k,l)
4886           enddo
4887         enddo
4888         write(iout,*) "ethetai",ethetai
4889         endif
4890         do m=1,ntheterm2
4891           do k=1,nsingle
4892             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4893      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4894      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4895      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4896             ethetai=ethetai+sinkt(m)*aux
4897             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4898             dephii=dephii+k*sinkt(m)*(
4899      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4900      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4901             dephii1=dephii1+k*sinkt(m)*(
4902      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4903      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4904             if (lprn)
4905      &      write (iout,*) "m",m," k",k," bbthet",
4906      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4907      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4908      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4909      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4910           enddo
4911         enddo
4912         if (lprn)
4913      &  write(iout,*) "ethetai",ethetai
4914         do m=1,ntheterm3
4915           do k=2,ndouble
4916             do l=1,k-1
4917               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4918      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4919      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4920      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4921               ethetai=ethetai+sinkt(m)*aux
4922               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4923               dephii=dephii+l*sinkt(m)*(
4924      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4925      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4926      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4927      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4928               dephii1=dephii1+(k-l)*sinkt(m)*(
4929      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4930      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4931      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4932      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4933               if (lprn) then
4934               write (iout,*) "m",m," k",k," l",l," ffthet",
4935      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4936      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4937      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4938      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4939               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4940      &            cosph1ph2(k,l)*sinkt(m),
4941      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4942               endif
4943             enddo
4944           enddo
4945         enddo
4946 10      continue
4947 c        lprn1=.true.
4948         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4949      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
4950      &   phii1*rad2deg,ethetai
4951 c        lprn1=.false.
4952         etheta=etheta+ethetai
4953         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4954         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4955         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4956       enddo
4957       return
4958       end
4959 #endif
4960 #ifdef CRYST_SC
4961 c-----------------------------------------------------------------------------
4962       subroutine esc(escloc)
4963 C Calculate the local energy of a side chain and its derivatives in the
4964 C corresponding virtual-bond valence angles THETA and the spherical angles
4965 C ALPHA and OMEGA.
4966       implicit real*8 (a-h,o-z)
4967       include 'DIMENSIONS'
4968       include 'COMMON.GEO'
4969       include 'COMMON.LOCAL'
4970       include 'COMMON.VAR'
4971       include 'COMMON.INTERACT'
4972       include 'COMMON.DERIV'
4973       include 'COMMON.CHAIN'
4974       include 'COMMON.IOUNITS'
4975       include 'COMMON.NAMES'
4976       include 'COMMON.FFIELD'
4977       include 'COMMON.CONTROL'
4978       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4979      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4980       common /sccalc/ time11,time12,time112,theti,it,nlobit
4981       delta=0.02d0*pi
4982       escloc=0.0D0
4983 c     write (iout,'(a)') 'ESC'
4984       do i=loc_start,loc_end
4985         it=itype(i)
4986         if (it.eq.10) goto 1
4987         nlobit=nlob(it)
4988 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4989 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4990         theti=theta(i+1)-pipol
4991         x(1)=dtan(theti)
4992         x(2)=alph(i)
4993         x(3)=omeg(i)
4994
4995         if (x(2).gt.pi-delta) then
4996           xtemp(1)=x(1)
4997           xtemp(2)=pi-delta
4998           xtemp(3)=x(3)
4999           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5000           xtemp(2)=pi
5001           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5002           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5003      &        escloci,dersc(2))
5004           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5005      &        ddersc0(1),dersc(1))
5006           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5007      &        ddersc0(3),dersc(3))
5008           xtemp(2)=pi-delta
5009           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5010           xtemp(2)=pi
5011           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5012           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5013      &            dersc0(2),esclocbi,dersc02)
5014           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5015      &            dersc12,dersc01)
5016           call splinthet(x(2),0.5d0*delta,ss,ssd)
5017           dersc0(1)=dersc01
5018           dersc0(2)=dersc02
5019           dersc0(3)=0.0d0
5020           do k=1,3
5021             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5022           enddo
5023           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5024 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5025 c    &             esclocbi,ss,ssd
5026           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5027 c         escloci=esclocbi
5028 c         write (iout,*) escloci
5029         else if (x(2).lt.delta) then
5030           xtemp(1)=x(1)
5031           xtemp(2)=delta
5032           xtemp(3)=x(3)
5033           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5034           xtemp(2)=0.0d0
5035           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5036           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5037      &        escloci,dersc(2))
5038           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5039      &        ddersc0(1),dersc(1))
5040           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5041      &        ddersc0(3),dersc(3))
5042           xtemp(2)=delta
5043           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5044           xtemp(2)=0.0d0
5045           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5046           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5047      &            dersc0(2),esclocbi,dersc02)
5048           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5049      &            dersc12,dersc01)
5050           dersc0(1)=dersc01
5051           dersc0(2)=dersc02
5052           dersc0(3)=0.0d0
5053           call splinthet(x(2),0.5d0*delta,ss,ssd)
5054           do k=1,3
5055             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5056           enddo
5057           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5058 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5059 c    &             esclocbi,ss,ssd
5060           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5061 c         write (iout,*) escloci
5062         else
5063           call enesc(x,escloci,dersc,ddummy,.false.)
5064         endif
5065
5066         escloc=escloc+escloci
5067         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5068      &     'escloc',i,escloci
5069 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5070
5071         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5072      &   wscloc*dersc(1)
5073         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5074         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5075     1   continue
5076       enddo
5077       return
5078       end
5079 C---------------------------------------------------------------------------
5080       subroutine enesc(x,escloci,dersc,ddersc,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,-1:1),dersc(3),ddersc(3)
5088       double precision contr(maxlob,-1:1)
5089       logical mixed
5090 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5091         escloc_i=0.0D0
5092         do j=1,3
5093           dersc(j)=0.0D0
5094           if (mixed) ddersc(j)=0.0d0
5095         enddo
5096         x3=x(3)
5097
5098 C Because of periodicity of the dependence of the SC energy in omega we have
5099 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5100 C To avoid underflows, first compute & store the exponents.
5101
5102         do iii=-1,1
5103
5104           x(3)=x3+iii*dwapi
5105
5106           do j=1,nlobit
5107             do k=1,3
5108               z(k)=x(k)-censc(k,j,it)
5109             enddo
5110             do k=1,3
5111               Axk=0.0D0
5112               do l=1,3
5113                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5114               enddo
5115               Ax(k,j,iii)=Axk
5116             enddo
5117             expfac=0.0D0
5118             do k=1,3
5119               expfac=expfac+Ax(k,j,iii)*z(k)
5120             enddo
5121             contr(j,iii)=expfac
5122           enddo ! j
5123
5124         enddo ! iii
5125
5126         x(3)=x3
5127 C As in the case of ebend, we want to avoid underflows in exponentiation and
5128 C subsequent NaNs and INFs in energy calculation.
5129 C Find the largest exponent
5130         emin=contr(1,-1)
5131         do iii=-1,1
5132           do j=1,nlobit
5133             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5134           enddo
5135         enddo
5136         emin=0.5D0*emin
5137 cd      print *,'it=',it,' emin=',emin
5138
5139 C Compute the contribution to SC energy and derivatives
5140         do iii=-1,1
5141
5142           do j=1,nlobit
5143 #ifdef OSF
5144             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5145             if(adexp.ne.adexp) adexp=1.0
5146             expfac=dexp(adexp)
5147 #else
5148             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5149 #endif
5150 cd          print *,'j=',j,' expfac=',expfac
5151             escloc_i=escloc_i+expfac
5152             do k=1,3
5153               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5154             enddo
5155             if (mixed) then
5156               do k=1,3,2
5157                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5158      &            +gaussc(k,2,j,it))*expfac
5159               enddo
5160             endif
5161           enddo
5162
5163         enddo ! iii
5164
5165         dersc(1)=dersc(1)/cos(theti)**2
5166         ddersc(1)=ddersc(1)/cos(theti)**2
5167         ddersc(3)=ddersc(3)
5168
5169         escloci=-(dlog(escloc_i)-emin)
5170         do j=1,3
5171           dersc(j)=dersc(j)/escloc_i
5172         enddo
5173         if (mixed) then
5174           do j=1,3,2
5175             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5176           enddo
5177         endif
5178       return
5179       end
5180 C------------------------------------------------------------------------------
5181       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5182       implicit real*8 (a-h,o-z)
5183       include 'DIMENSIONS'
5184       include 'COMMON.GEO'
5185       include 'COMMON.LOCAL'
5186       include 'COMMON.IOUNITS'
5187       common /sccalc/ time11,time12,time112,theti,it,nlobit
5188       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5189       double precision contr(maxlob)
5190       logical mixed
5191
5192       escloc_i=0.0D0
5193
5194       do j=1,3
5195         dersc(j)=0.0D0
5196       enddo
5197
5198       do j=1,nlobit
5199         do k=1,2
5200           z(k)=x(k)-censc(k,j,it)
5201         enddo
5202         z(3)=dwapi
5203         do k=1,3
5204           Axk=0.0D0
5205           do l=1,3
5206             Axk=Axk+gaussc(l,k,j,it)*z(l)
5207           enddo
5208           Ax(k,j)=Axk
5209         enddo
5210         expfac=0.0D0
5211         do k=1,3
5212           expfac=expfac+Ax(k,j)*z(k)
5213         enddo
5214         contr(j)=expfac
5215       enddo ! j
5216
5217 C As in the case of ebend, we want to avoid underflows in exponentiation and
5218 C subsequent NaNs and INFs in energy calculation.
5219 C Find the largest exponent
5220       emin=contr(1)
5221       do j=1,nlobit
5222         if (emin.gt.contr(j)) emin=contr(j)
5223       enddo
5224       emin=0.5D0*emin
5225
5226 C Compute the contribution to SC energy and derivatives
5227
5228       dersc12=0.0d0
5229       do j=1,nlobit
5230         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5231         escloc_i=escloc_i+expfac
5232         do k=1,2
5233           dersc(k)=dersc(k)+Ax(k,j)*expfac
5234         enddo
5235         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5236      &            +gaussc(1,2,j,it))*expfac
5237         dersc(3)=0.0d0
5238       enddo
5239
5240       dersc(1)=dersc(1)/cos(theti)**2
5241       dersc12=dersc12/cos(theti)**2
5242       escloci=-(dlog(escloc_i)-emin)
5243       do j=1,2
5244         dersc(j)=dersc(j)/escloc_i
5245       enddo
5246       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5247       return
5248       end
5249 #else
5250 c----------------------------------------------------------------------------------
5251       subroutine esc(escloc)
5252 C Calculate the local energy of a side chain and its derivatives in the
5253 C corresponding virtual-bond valence angles THETA and the spherical angles
5254 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5255 C added by Urszula Kozlowska. 07/11/2007
5256 C
5257       implicit real*8 (a-h,o-z)
5258       include 'DIMENSIONS'
5259       include 'COMMON.GEO'
5260       include 'COMMON.LOCAL'
5261       include 'COMMON.VAR'
5262       include 'COMMON.SCROT'
5263       include 'COMMON.INTERACT'
5264       include 'COMMON.DERIV'
5265       include 'COMMON.CHAIN'
5266       include 'COMMON.IOUNITS'
5267       include 'COMMON.NAMES'
5268       include 'COMMON.FFIELD'
5269       include 'COMMON.CONTROL'
5270       include 'COMMON.VECTORS'
5271       double precision x_prime(3),y_prime(3),z_prime(3)
5272      &    , sumene,dsc_i,dp2_i,x(65),
5273      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5274      &    de_dxx,de_dyy,de_dzz,de_dt
5275       double precision s1_t,s1_6_t,s2_t,s2_6_t
5276       double precision
5277      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5278      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5279      & dt_dCi(3),dt_dCi1(3)
5280       common /sccalc/ time11,time12,time112,theti,it,nlobit
5281       delta=0.02d0*pi
5282       escloc=0.0D0
5283       do i=loc_start,loc_end
5284         costtab(i+1) =dcos(theta(i+1))
5285         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5286         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5287         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5288         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5289         cosfac=dsqrt(cosfac2)
5290         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5291         sinfac=dsqrt(sinfac2)
5292         it=itype(i)
5293         if (it.eq.10) goto 1
5294 c
5295 C  Compute the axes of tghe local cartesian coordinates system; store in
5296 c   x_prime, y_prime and z_prime
5297 c
5298         do j=1,3
5299           x_prime(j) = 0.00
5300           y_prime(j) = 0.00
5301           z_prime(j) = 0.00
5302         enddo
5303 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5304 C     &   dc_norm(3,i+nres)
5305         do j = 1,3
5306           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5307           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5308         enddo
5309         do j = 1,3
5310           z_prime(j) = -uz(j,i-1)
5311         enddo
5312 c       write (2,*) "i",i
5313 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5314 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5315 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5316 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5317 c      & " xy",scalar(x_prime(1),y_prime(1)),
5318 c      & " xz",scalar(x_prime(1),z_prime(1)),
5319 c      & " yy",scalar(y_prime(1),y_prime(1)),
5320 c      & " yz",scalar(y_prime(1),z_prime(1)),
5321 c      & " zz",scalar(z_prime(1),z_prime(1))
5322 c
5323 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5324 C to local coordinate system. Store in xx, yy, zz.
5325 c
5326         xx=0.0d0
5327         yy=0.0d0
5328         zz=0.0d0
5329         do j = 1,3
5330           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5331           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5332           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5333         enddo
5334
5335         xxtab(i)=xx
5336         yytab(i)=yy
5337         zztab(i)=zz
5338 C
5339 C Compute the energy of the ith side cbain
5340 C
5341 c        write (2,*) "xx",xx," yy",yy," zz",zz
5342         it=itype(i)
5343         do j = 1,65
5344           x(j) = sc_parmin(j,it)
5345         enddo
5346 #ifdef CHECK_COORD
5347 Cc diagnostics - remove later
5348         xx1 = dcos(alph(2))
5349         yy1 = dsin(alph(2))*dcos(omeg(2))
5350         zz1 = -dsin(alph(2))*dsin(omeg(2))
5351         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5352      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5353      &    xx1,yy1,zz1
5354 C,"  --- ", xx_w,yy_w,zz_w
5355 c end diagnostics
5356 #endif
5357         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5358      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5359      &   + x(10)*yy*zz
5360         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5361      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5362      & + x(20)*yy*zz
5363         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5364      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5365      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5366      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5367      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5368      &  +x(40)*xx*yy*zz
5369         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5370      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5371      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5372      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5373      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5374      &  +x(60)*xx*yy*zz
5375         dsc_i   = 0.743d0+x(61)
5376         dp2_i   = 1.9d0+x(62)
5377         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5378      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5379         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5380      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5381         s1=(1+x(63))/(0.1d0 + dscp1)
5382         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5383         s2=(1+x(65))/(0.1d0 + dscp2)
5384         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5385         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5386      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5387 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5388 c     &   sumene4,
5389 c     &   dscp1,dscp2,sumene
5390 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5391         escloc = escloc + sumene
5392 c        write (2,*) "i",i," escloc",sumene,escloc
5393 #ifdef DEBUG
5394 C
5395 C This section to check the numerical derivatives of the energy of ith side
5396 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5397 C #define DEBUG in the code to turn it on.
5398 C
5399         write (2,*) "sumene               =",sumene
5400         aincr=1.0d-7
5401         xxsave=xx
5402         xx=xx+aincr
5403         write (2,*) xx,yy,zz
5404         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5405         de_dxx_num=(sumenep-sumene)/aincr
5406         xx=xxsave
5407         write (2,*) "xx+ sumene from enesc=",sumenep
5408         yysave=yy
5409         yy=yy+aincr
5410         write (2,*) xx,yy,zz
5411         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5412         de_dyy_num=(sumenep-sumene)/aincr
5413         yy=yysave
5414         write (2,*) "yy+ sumene from enesc=",sumenep
5415         zzsave=zz
5416         zz=zz+aincr
5417         write (2,*) xx,yy,zz
5418         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5419         de_dzz_num=(sumenep-sumene)/aincr
5420         zz=zzsave
5421         write (2,*) "zz+ sumene from enesc=",sumenep
5422         costsave=cost2tab(i+1)
5423         sintsave=sint2tab(i+1)
5424         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5425         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5426         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5427         de_dt_num=(sumenep-sumene)/aincr
5428         write (2,*) " t+ sumene from enesc=",sumenep
5429         cost2tab(i+1)=costsave
5430         sint2tab(i+1)=sintsave
5431 C End of diagnostics section.
5432 #endif
5433 C
5434 C Compute the gradient of esc
5435 C
5436         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5437         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5438         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5439         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5440         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5441         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5442         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5443         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5444         pom1=(sumene3*sint2tab(i+1)+sumene1)
5445      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5446         pom2=(sumene4*cost2tab(i+1)+sumene2)
5447      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5448         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5449         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5450      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5451      &  +x(40)*yy*zz
5452         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5453         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5454      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5455      &  +x(60)*yy*zz
5456         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5457      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5458      &        +(pom1+pom2)*pom_dx
5459 #ifdef DEBUG
5460         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5461 #endif
5462 C
5463         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5464         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5465      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5466      &  +x(40)*xx*zz
5467         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5468         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5469      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5470      &  +x(59)*zz**2 +x(60)*xx*zz
5471         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5472      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5473      &        +(pom1-pom2)*pom_dy
5474 #ifdef DEBUG
5475         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5476 #endif
5477 C
5478         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5479      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5480      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5481      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5482      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5483      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5484      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5485      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5486 #ifdef DEBUG
5487         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5488 #endif
5489 C
5490         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5491      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5492      &  +pom1*pom_dt1+pom2*pom_dt2
5493 #ifdef DEBUG
5494         write(2,*), "de_dt = ", de_dt,de_dt_num
5495 #endif
5496 c
5497 C
5498        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5499        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5500        cosfac2xx=cosfac2*xx
5501        sinfac2yy=sinfac2*yy
5502        do k = 1,3
5503          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5504      &      vbld_inv(i+1)
5505          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5506      &      vbld_inv(i)
5507          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5508          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5509 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5510 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5511 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5512 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5513          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5514          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5515          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5516          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5517          dZZ_Ci1(k)=0.0d0
5518          dZZ_Ci(k)=0.0d0
5519          do j=1,3
5520            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5521            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5522          enddo
5523
5524          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5525          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5526          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5527 c
5528          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5529          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5530        enddo
5531
5532        do k=1,3
5533          dXX_Ctab(k,i)=dXX_Ci(k)
5534          dXX_C1tab(k,i)=dXX_Ci1(k)
5535          dYY_Ctab(k,i)=dYY_Ci(k)
5536          dYY_C1tab(k,i)=dYY_Ci1(k)
5537          dZZ_Ctab(k,i)=dZZ_Ci(k)
5538          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5539          dXX_XYZtab(k,i)=dXX_XYZ(k)
5540          dYY_XYZtab(k,i)=dYY_XYZ(k)
5541          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5542        enddo
5543
5544        do k = 1,3
5545 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5546 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5547 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5548 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5549 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5550 c     &    dt_dci(k)
5551 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5552 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5553          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5554      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5555          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5556      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5557          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5558      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5559        enddo
5560 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5561 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5562
5563 C to check gradient call subroutine check_grad
5564
5565     1 continue
5566       enddo
5567       return
5568       end
5569 c------------------------------------------------------------------------------
5570       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5571       implicit none
5572       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5573      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5574       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5575      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5576      &   + x(10)*yy*zz
5577       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5578      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5579      & + x(20)*yy*zz
5580       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5581      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5582      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5583      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5584      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5585      &  +x(40)*xx*yy*zz
5586       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5587      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5588      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5589      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5590      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5591      &  +x(60)*xx*yy*zz
5592       dsc_i   = 0.743d0+x(61)
5593       dp2_i   = 1.9d0+x(62)
5594       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5595      &          *(xx*cost2+yy*sint2))
5596       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5597      &          *(xx*cost2-yy*sint2))
5598       s1=(1+x(63))/(0.1d0 + dscp1)
5599       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5600       s2=(1+x(65))/(0.1d0 + dscp2)
5601       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5602       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5603      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5604       enesc=sumene
5605       return
5606       end
5607 #endif
5608 c------------------------------------------------------------------------------
5609       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5610 C
5611 C This procedure calculates two-body contact function g(rij) and its derivative:
5612 C
5613 C           eps0ij                                     !       x < -1
5614 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5615 C            0                                         !       x > 1
5616 C
5617 C where x=(rij-r0ij)/delta
5618 C
5619 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5620 C
5621       implicit none
5622       double precision rij,r0ij,eps0ij,fcont,fprimcont
5623       double precision x,x2,x4,delta
5624 c     delta=0.02D0*r0ij
5625 c      delta=0.2D0*r0ij
5626       x=(rij-r0ij)/delta
5627       if (x.lt.-1.0D0) then
5628         fcont=eps0ij
5629         fprimcont=0.0D0
5630       else if (x.le.1.0D0) then
5631         x2=x*x
5632         x4=x2*x2
5633         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5634         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5635       else
5636         fcont=0.0D0
5637         fprimcont=0.0D0
5638       endif
5639       return
5640       end
5641 c------------------------------------------------------------------------------
5642       subroutine splinthet(theti,delta,ss,ssder)
5643       implicit real*8 (a-h,o-z)
5644       include 'DIMENSIONS'
5645       include 'COMMON.VAR'
5646       include 'COMMON.GEO'
5647       thetup=pi-delta
5648       thetlow=delta
5649       if (theti.gt.pipol) then
5650         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5651       else
5652         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5653         ssder=-ssder
5654       endif
5655       return
5656       end
5657 c------------------------------------------------------------------------------
5658       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5659       implicit none
5660       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5661       double precision ksi,ksi2,ksi3,a1,a2,a3
5662       a1=fprim0*delta/(f1-f0)
5663       a2=3.0d0-2.0d0*a1
5664       a3=a1-2.0d0
5665       ksi=(x-x0)/delta
5666       ksi2=ksi*ksi
5667       ksi3=ksi2*ksi
5668       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5669       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5670       return
5671       end
5672 c------------------------------------------------------------------------------
5673       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5674       implicit none
5675       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5676       double precision ksi,ksi2,ksi3,a1,a2,a3
5677       ksi=(x-x0)/delta
5678       ksi2=ksi*ksi
5679       ksi3=ksi2*ksi
5680       a1=fprim0x*delta
5681       a2=3*(f1x-f0x)-2*fprim0x*delta
5682       a3=fprim0x*delta-2*(f1x-f0x)
5683       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5684       return
5685       end
5686 C-----------------------------------------------------------------------------
5687 #ifdef CRYST_TOR
5688 C-----------------------------------------------------------------------------
5689       subroutine etor(etors,edihcnstr)
5690       implicit real*8 (a-h,o-z)
5691       include 'DIMENSIONS'
5692       include 'COMMON.VAR'
5693       include 'COMMON.GEO'
5694       include 'COMMON.LOCAL'
5695       include 'COMMON.TORSION'
5696       include 'COMMON.INTERACT'
5697       include 'COMMON.DERIV'
5698       include 'COMMON.CHAIN'
5699       include 'COMMON.NAMES'
5700       include 'COMMON.IOUNITS'
5701       include 'COMMON.FFIELD'
5702       include 'COMMON.TORCNSTR'
5703       include 'COMMON.CONTROL'
5704       logical lprn
5705 C Set lprn=.true. for debugging
5706       lprn=.false.
5707 c      lprn=.true.
5708       etors=0.0D0
5709       do i=iphi_start,iphi_end
5710       etors_ii=0.0D0
5711         itori=itortyp(itype(i-2))
5712         itori1=itortyp(itype(i-1))
5713         phii=phi(i)
5714         gloci=0.0D0
5715 C Proline-Proline pair is a special case...
5716         if (itori.eq.3 .and. itori1.eq.3) then
5717           if (phii.gt.-dwapi3) then
5718             cosphi=dcos(3*phii)
5719             fac=1.0D0/(1.0D0-cosphi)
5720             etorsi=v1(1,3,3)*fac
5721             etorsi=etorsi+etorsi
5722             etors=etors+etorsi-v1(1,3,3)
5723             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5724             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5725           endif
5726           do j=1,3
5727             v1ij=v1(j+1,itori,itori1)
5728             v2ij=v2(j+1,itori,itori1)
5729             cosphi=dcos(j*phii)
5730             sinphi=dsin(j*phii)
5731             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5732             if (energy_dec) etors_ii=etors_ii+
5733      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5734             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5735           enddo
5736         else
5737           do j=1,nterm_old
5738             v1ij=v1(j,itori,itori1)
5739             v2ij=v2(j,itori,itori1)
5740             cosphi=dcos(j*phii)
5741             sinphi=dsin(j*phii)
5742             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5743             if (energy_dec) etors_ii=etors_ii+
5744      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5745             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5746           enddo
5747         endif
5748         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5749      &        'etor',i,etors_ii
5750         if (lprn)
5751      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5752      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5753      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5754         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5755         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5756       enddo
5757 ! 6/20/98 - dihedral angle constraints
5758       edihcnstr=0.0d0
5759       do i=1,ndih_constr
5760         itori=idih_constr(i)
5761         phii=phi(itori)
5762         difi=phii-phi0(i)
5763         if (difi.gt.drange(i)) then
5764           difi=difi-drange(i)
5765           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5766           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5767         else if (difi.lt.-drange(i)) then
5768           difi=difi+drange(i)
5769           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5770           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5771         endif
5772 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5773 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5774       enddo
5775 !      write (iout,*) 'edihcnstr',edihcnstr
5776       return
5777       end
5778 c------------------------------------------------------------------------------
5779 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
5780       subroutine e_modeller(ehomology_constr)
5781       ehomology_constr=0.0
5782       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
5783       return
5784       end
5785 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
5786
5787 c------------------------------------------------------------------------------
5788       subroutine etor_d(etors_d)
5789       etors_d=0.0d0
5790       return
5791       end
5792 c----------------------------------------------------------------------------
5793 #else
5794       subroutine etor(etors,edihcnstr)
5795       implicit real*8 (a-h,o-z)
5796       include 'DIMENSIONS'
5797       include 'COMMON.VAR'
5798       include 'COMMON.GEO'
5799       include 'COMMON.LOCAL'
5800       include 'COMMON.TORSION'
5801       include 'COMMON.INTERACT'
5802       include 'COMMON.DERIV'
5803       include 'COMMON.CHAIN'
5804       include 'COMMON.NAMES'
5805       include 'COMMON.IOUNITS'
5806       include 'COMMON.FFIELD'
5807       include 'COMMON.TORCNSTR'
5808       include 'COMMON.CONTROL'
5809       logical lprn
5810 C Set lprn=.true. for debugging
5811       lprn=.false.
5812 c     lprn=.true.
5813       etors=0.0D0
5814       do i=iphi_start,iphi_end
5815       etors_ii=0.0D0
5816         itori=itortyp(itype(i-2))
5817         itori1=itortyp(itype(i-1))
5818         phii=phi(i)
5819         gloci=0.0D0
5820 C Regular cosine and sine terms
5821         do j=1,nterm(itori,itori1)
5822           v1ij=v1(j,itori,itori1)
5823           v2ij=v2(j,itori,itori1)
5824           cosphi=dcos(j*phii)
5825           sinphi=dsin(j*phii)
5826           etors=etors+v1ij*cosphi+v2ij*sinphi
5827           if (energy_dec) etors_ii=etors_ii+
5828      &                v1ij*cosphi+v2ij*sinphi
5829           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5830         enddo
5831 C Lorentz terms
5832 C                         v1
5833 C  E = SUM ----------------------------------- - v1
5834 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5835 C
5836         cosphi=dcos(0.5d0*phii)
5837         sinphi=dsin(0.5d0*phii)
5838         do j=1,nlor(itori,itori1)
5839           vl1ij=vlor1(j,itori,itori1)
5840           vl2ij=vlor2(j,itori,itori1)
5841           vl3ij=vlor3(j,itori,itori1)
5842           pom=vl2ij*cosphi+vl3ij*sinphi
5843           pom1=1.0d0/(pom*pom+1.0d0)
5844           etors=etors+vl1ij*pom1
5845           if (energy_dec) etors_ii=etors_ii+
5846      &                vl1ij*pom1
5847           pom=-pom*pom1*pom1
5848           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5849         enddo
5850 C Subtract the constant term
5851         etors=etors-v0(itori,itori1)
5852           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5853      &         'etor',i,etors_ii-v0(itori,itori1)
5854         if (lprn)
5855      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5856      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5857      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5858         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5859 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5860       enddo
5861 ! 6/20/98 - dihedral angle constraints
5862       edihcnstr=0.0d0
5863 c      do i=1,ndih_constr
5864       do i=idihconstr_start,idihconstr_end
5865         itori=idih_constr(i)
5866         phii=phi(itori)
5867         difi=pinorm(phii-phi0(i))
5868         if (difi.gt.drange(i)) then
5869           difi=difi-drange(i)
5870           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5871           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5872         else if (difi.lt.-drange(i)) then
5873           difi=difi+drange(i)
5874           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5875           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5876         else
5877           difi=0.0
5878         endif
5879 c        write (iout,*) "gloci", gloc(i-3,icg)
5880 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5881 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5882 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5883       enddo
5884 cd       write (iout,*) 'edihcnstr',edihcnstr
5885       return
5886       end
5887 c----------------------------------------------------------------------------
5888 c MODELLER restraint function
5889       subroutine e_modeller(ehomology_constr)
5890       implicit real*8 (a-h,o-z)
5891       include 'DIMENSIONS'
5892
5893       integer nnn, i, j, k, ki, irec, l
5894       integer katy, odleglosci, test7
5895       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
5896       real*8 distance(max_template),distancek(max_template),
5897      &    min_odl,godl(max_template),dih_diff(max_template)
5898
5899       include 'COMMON.SBRIDGE'
5900       include 'COMMON.CHAIN'
5901       include 'COMMON.GEO'
5902       include 'COMMON.DERIV'
5903       include 'COMMON.LOCAL'
5904       include 'COMMON.INTERACT'
5905       include 'COMMON.VAR'
5906       include 'COMMON.IOUNITS'
5907       include 'COMMON.MD'
5908       include 'COMMON.CONTROL'
5909
5910
5911       do i=1,19
5912         distancek(i)=9999999.9
5913       enddo
5914
5915
5916       odleg=0.0d0
5917
5918 c Pseudo-energy and gradient from homology restraints (MODELLER-like
5919 c function)
5920 C AL 5/2/14 - Introduce list of restraints
5921       do ii = link_start_homo,link_end_homo
5922          i = ires_homo(ii)
5923          j = jres_homo(ii)
5924          dij=dist(i,j)
5925          do k=1,constr_homology
5926            distance(k)=odl(k,ii)-dij
5927            distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
5928          enddo
5929
5930          min_odl=minval(distancek)
5931 #ifdef DEBUG
5932          write (iout,*) "ij dij",i,j,dij
5933          write (iout,*) "distance",(distance(k),k=1,constr_homology)
5934          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
5935          write (iout,* )"min_odl",min_odl
5936 #endif
5937          odleg2=0.0d0
5938          do k=1,constr_homology
5939 c Nie wiem po co to liczycie jeszcze raz!
5940 c            odleg3=-waga_dist*((distance(i,j,k)**2)/
5941 c     &              (2*(sigma_odl(i,j,k))**2))
5942             godl(k)=dexp(-distancek(k)+min_odl)
5943             odleg2=odleg2+godl(k)
5944
5945 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
5946 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
5947 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
5948 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
5949
5950          enddo
5951 #ifdef DEBUG
5952          write (iout,*) "godl",(godl(k),k=1,constr_homology)
5953          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2
5954 #endif
5955          odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
5956 c Gradient
5957          sum_godl=odleg2
5958          sum_sgodl=0.0
5959          do k=1,constr_homology
5960 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
5961 c     &           *waga_dist)+min_odl
5962            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
5963            sum_sgodl=sum_sgodl+sgodl
5964
5965 c            sgodl2=sgodl2+sgodl
5966 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
5967 c      write(iout,*) "constr_homology=",constr_homology
5968 c      write(iout,*) i, j, k, "TEST K"
5969          enddo
5970
5971          grad_odl3=sum_sgodl/(sum_godl*dij)
5972
5973
5974 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
5975 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
5976 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
5977
5978 ccc      write(iout,*) godl, sgodl, grad_odl3
5979
5980 c          grad_odl=grad_odl+grad_odl3
5981
5982          do jik=1,3
5983             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
5984 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
5985 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
5986 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
5987             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
5988             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
5989 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
5990 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
5991
5992          enddo
5993 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
5994 ccc     & dLOG(odleg2),"-odleg=", -odleg
5995
5996       enddo ! ii
5997 c Pseudo-energy and gradient from dihedral-angle restraints from
5998 c homology templates
5999 c      write (iout,*) "End of distance loop"
6000 c      call flush(iout)
6001       kat=0.0d0
6002 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
6003       do i=idihconstr_start_homo,idihconstr_end_homo
6004         kat2=0.0d0
6005 c        betai=beta(i,i+1,i+2,i+3)
6006         betai = phi(i+3)
6007         do k=1,constr_homology
6008           dih_diff(k)=pinorm(dih(k,i)-betai)
6009 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
6010 c     &                                   -(6.28318-dih_diff(i,k))
6011 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
6012 c     &                                   6.28318+dih_diff(i,k)
6013
6014           kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
6015           gdih(k)=dexp(kat3)
6016           kat2=kat2+gdih(k)
6017 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
6018 c          write(*,*)""
6019         enddo
6020 #ifdef DEBUG
6021         write (iout,*) "i",i," betai",betai," kat2",kat2
6022         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
6023 #endif
6024         if (kat2.le.1.0d-14) cycle
6025         kat=kat-dLOG(kat2/constr_homology)
6026
6027 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
6028 ccc     & dLOG(kat2), "-kat=", -kat
6029
6030 c ----------------------------------------------------------------------
6031 c Gradient
6032 c ----------------------------------------------------------------------
6033
6034         sum_gdih=kat2
6035         sum_sgdih=0.0
6036         do k=1,constr_homology
6037           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
6038           sum_sgdih=sum_sgdih+sgdih
6039         enddo
6040         grad_dih3=sum_sgdih/sum_gdih
6041
6042 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
6043 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
6044 ccc     & gloc(nphi+i-3,icg)
6045         gloc(i,icg)=gloc(i,icg)+grad_dih3
6046 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
6047 ccc     & gloc(nphi+i-3,icg)
6048
6049       enddo
6050
6051
6052 c Total energy from homology restraints
6053 #ifdef DEBUG
6054       write (iout,*) "odleg",odleg," kat",kat
6055 #endif
6056       ehomology_constr=odleg+kat
6057       return
6058
6059   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
6060   747 format(a12,i4,i4,i4,f8.3,f8.3)
6061   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
6062   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
6063   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
6064      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
6065       end
6066
6067 c------------------------------------------------------------------------------
6068       subroutine etor_d(etors_d)
6069 C 6/23/01 Compute double torsional energy
6070       implicit real*8 (a-h,o-z)
6071       include 'DIMENSIONS'
6072       include 'COMMON.VAR'
6073       include 'COMMON.GEO'
6074       include 'COMMON.LOCAL'
6075       include 'COMMON.TORSION'
6076       include 'COMMON.INTERACT'
6077       include 'COMMON.DERIV'
6078       include 'COMMON.CHAIN'
6079       include 'COMMON.NAMES'
6080       include 'COMMON.IOUNITS'
6081       include 'COMMON.FFIELD'
6082       include 'COMMON.TORCNSTR'
6083       logical lprn
6084 C Set lprn=.true. for debugging
6085       lprn=.false.
6086 c     lprn=.true.
6087       etors_d=0.0D0
6088       do i=iphid_start,iphid_end
6089         itori=itortyp(itype(i-2))
6090         itori1=itortyp(itype(i-1))
6091         itori2=itortyp(itype(i))
6092         phii=phi(i)
6093         phii1=phi(i+1)
6094         gloci1=0.0D0
6095         gloci2=0.0D0
6096         do j=1,ntermd_1(itori,itori1,itori2)
6097           v1cij=v1c(1,j,itori,itori1,itori2)
6098           v1sij=v1s(1,j,itori,itori1,itori2)
6099           v2cij=v1c(2,j,itori,itori1,itori2)
6100           v2sij=v1s(2,j,itori,itori1,itori2)
6101           cosphi1=dcos(j*phii)
6102           sinphi1=dsin(j*phii)
6103           cosphi2=dcos(j*phii1)
6104           sinphi2=dsin(j*phii1)
6105           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6106      &     v2cij*cosphi2+v2sij*sinphi2
6107           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6108           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6109         enddo
6110         do k=2,ntermd_2(itori,itori1,itori2)
6111           do l=1,k-1
6112             v1cdij = v2c(k,l,itori,itori1,itori2)
6113             v2cdij = v2c(l,k,itori,itori1,itori2)
6114             v1sdij = v2s(k,l,itori,itori1,itori2)
6115             v2sdij = v2s(l,k,itori,itori1,itori2)
6116             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6117             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6118             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6119             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6120             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6121      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6122             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6123      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6124             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6125      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6126           enddo
6127         enddo
6128         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6129         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6130 c        write (iout,*) "gloci", gloc(i-3,icg)
6131       enddo
6132       return
6133       end
6134 #endif
6135 c------------------------------------------------------------------------------
6136       subroutine eback_sc_corr(esccor)
6137 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6138 c        conformational states; temporarily implemented as differences
6139 c        between UNRES torsional potentials (dependent on three types of
6140 c        residues) and the torsional potentials dependent on all 20 types
6141 c        of residues computed from AM1  energy surfaces of terminally-blocked
6142 c        amino-acid residues.
6143       implicit real*8 (a-h,o-z)
6144       include 'DIMENSIONS'
6145       include 'COMMON.VAR'
6146       include 'COMMON.GEO'
6147       include 'COMMON.LOCAL'
6148       include 'COMMON.TORSION'
6149       include 'COMMON.SCCOR'
6150       include 'COMMON.INTERACT'
6151       include 'COMMON.DERIV'
6152       include 'COMMON.CHAIN'
6153       include 'COMMON.NAMES'
6154       include 'COMMON.IOUNITS'
6155       include 'COMMON.FFIELD'
6156       include 'COMMON.CONTROL'
6157       logical lprn
6158 C Set lprn=.true. for debugging
6159       lprn=.false.
6160 c      lprn=.true.
6161 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6162       esccor=0.0D0
6163       do i=itau_start,itau_end
6164         esccor_ii=0.0D0
6165         isccori=isccortyp(itype(i-2))
6166         isccori1=isccortyp(itype(i-1))
6167         phii=phi(i)
6168 cccc  Added 9 May 2012
6169 cc Tauangle is torsional engle depending on the value of first digit
6170 c(see comment below)
6171 cc Omicron is flat angle depending on the value of first digit
6172 c(see comment below)
6173
6174
6175         do intertyp=1,3 !intertyp
6176 cc Added 09 May 2012 (Adasko)
6177 cc  Intertyp means interaction type of backbone mainchain correlation:
6178 c   1 = SC...Ca...Ca...Ca
6179 c   2 = Ca...Ca...Ca...SC
6180 c   3 = SC...Ca...Ca...SCi
6181         gloci=0.0D0
6182         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6183      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6184      &      (itype(i-1).eq.21)))
6185      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6186      &     .or.(itype(i-2).eq.21)))
6187      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6188      &      (itype(i-1).eq.21)))) cycle
6189         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6190         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6191      & cycle
6192         do j=1,nterm_sccor(isccori,isccori1)
6193           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6194           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6195           cosphi=dcos(j*tauangle(intertyp,i))
6196           sinphi=dsin(j*tauangle(intertyp,i))
6197           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6198           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6199         enddo
6200         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6201 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6202 c     &gloc_sc(intertyp,i-3,icg)
6203         if (lprn)
6204      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6205      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6206      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6207      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6208         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6209        enddo !intertyp
6210       enddo
6211 c        do i=1,nres
6212 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6213 c        enddo
6214       return
6215       end
6216 c----------------------------------------------------------------------------
6217       subroutine multibody(ecorr)
6218 C This subroutine calculates multi-body contributions to energy following
6219 C the idea of Skolnick et al. If side chains I and J make a contact and
6220 C at the same time side chains I+1 and J+1 make a contact, an extra
6221 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6222       implicit real*8 (a-h,o-z)
6223       include 'DIMENSIONS'
6224       include 'COMMON.IOUNITS'
6225       include 'COMMON.DERIV'
6226       include 'COMMON.INTERACT'
6227       include 'COMMON.CONTACTS'
6228       double precision gx(3),gx1(3)
6229       logical lprn
6230
6231 C Set lprn=.true. for debugging
6232       lprn=.false.
6233
6234       if (lprn) then
6235         write (iout,'(a)') 'Contact function values:'
6236         do i=nnt,nct-2
6237           write (iout,'(i2,20(1x,i2,f10.5))')
6238      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6239         enddo
6240       endif
6241       ecorr=0.0D0
6242       do i=nnt,nct
6243         do j=1,3
6244           gradcorr(j,i)=0.0D0
6245           gradxorr(j,i)=0.0D0
6246         enddo
6247       enddo
6248       do i=nnt,nct-2
6249
6250         DO ISHIFT = 3,4
6251
6252         i1=i+ishift
6253         num_conti=num_cont(i)
6254         num_conti1=num_cont(i1)
6255         do jj=1,num_conti
6256           j=jcont(jj,i)
6257           do kk=1,num_conti1
6258             j1=jcont(kk,i1)
6259             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6260 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6261 cd   &                   ' ishift=',ishift
6262 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6263 C The system gains extra energy.
6264               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6265             endif   ! j1==j+-ishift
6266           enddo     ! kk
6267         enddo       ! jj
6268
6269         ENDDO ! ISHIFT
6270
6271       enddo         ! i
6272       return
6273       end
6274 c------------------------------------------------------------------------------
6275       double precision function esccorr(i,j,k,l,jj,kk)
6276       implicit real*8 (a-h,o-z)
6277       include 'DIMENSIONS'
6278       include 'COMMON.IOUNITS'
6279       include 'COMMON.DERIV'
6280       include 'COMMON.INTERACT'
6281       include 'COMMON.CONTACTS'
6282       double precision gx(3),gx1(3)
6283       logical lprn
6284       lprn=.false.
6285       eij=facont(jj,i)
6286       ekl=facont(kk,k)
6287 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6288 C Calculate the multi-body contribution to energy.
6289 C Calculate multi-body contributions to the gradient.
6290 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6291 cd   & k,l,(gacont(m,kk,k),m=1,3)
6292       do m=1,3
6293         gx(m) =ekl*gacont(m,jj,i)
6294         gx1(m)=eij*gacont(m,kk,k)
6295         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6296         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6297         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6298         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6299       enddo
6300       do m=i,j-1
6301         do ll=1,3
6302           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6303         enddo
6304       enddo
6305       do m=k,l-1
6306         do ll=1,3
6307           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6308         enddo
6309       enddo
6310       esccorr=-eij*ekl
6311       return
6312       end
6313 c------------------------------------------------------------------------------
6314       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6315 C This subroutine calculates multi-body contributions to hydrogen-bonding
6316       implicit real*8 (a-h,o-z)
6317       include 'DIMENSIONS'
6318       include 'COMMON.IOUNITS'
6319 #ifdef MPI
6320       include "mpif.h"
6321       parameter (max_cont=maxconts)
6322       parameter (max_dim=26)
6323       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6324       double precision zapas(max_dim,maxconts,max_fg_procs),
6325      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6326       common /przechowalnia/ zapas
6327       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6328      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6329 #endif
6330       include 'COMMON.SETUP'
6331       include 'COMMON.FFIELD'
6332       include 'COMMON.DERIV'
6333       include 'COMMON.INTERACT'
6334       include 'COMMON.CONTACTS'
6335       include 'COMMON.CONTROL'
6336       include 'COMMON.LOCAL'
6337       double precision gx(3),gx1(3),time00
6338       logical lprn,ldone
6339
6340 C Set lprn=.true. for debugging
6341       lprn=.false.
6342 #ifdef MPI
6343       n_corr=0
6344       n_corr1=0
6345       if (nfgtasks.le.1) goto 30
6346       if (lprn) then
6347         write (iout,'(a)') 'Contact function values before RECEIVE:'
6348         do i=nnt,nct-2
6349           write (iout,'(2i3,50(1x,i2,f5.2))')
6350      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6351      &    j=1,num_cont_hb(i))
6352         enddo
6353       endif
6354       call flush(iout)
6355       do i=1,ntask_cont_from
6356         ncont_recv(i)=0
6357       enddo
6358       do i=1,ntask_cont_to
6359         ncont_sent(i)=0
6360       enddo
6361 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6362 c     & ntask_cont_to
6363 C Make the list of contacts to send to send to other procesors
6364 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6365 c      call flush(iout)
6366       do i=iturn3_start,iturn3_end
6367 c        write (iout,*) "make contact list turn3",i," num_cont",
6368 c     &    num_cont_hb(i)
6369         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6370       enddo
6371       do i=iturn4_start,iturn4_end
6372 c        write (iout,*) "make contact list turn4",i," num_cont",
6373 c     &   num_cont_hb(i)
6374         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6375       enddo
6376       do ii=1,nat_sent
6377         i=iat_sent(ii)
6378 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6379 c     &    num_cont_hb(i)
6380         do j=1,num_cont_hb(i)
6381         do k=1,4
6382           jjc=jcont_hb(j,i)
6383           iproc=iint_sent_local(k,jjc,ii)
6384 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6385           if (iproc.gt.0) then
6386             ncont_sent(iproc)=ncont_sent(iproc)+1
6387             nn=ncont_sent(iproc)
6388             zapas(1,nn,iproc)=i
6389             zapas(2,nn,iproc)=jjc
6390             zapas(3,nn,iproc)=facont_hb(j,i)
6391             zapas(4,nn,iproc)=ees0p(j,i)
6392             zapas(5,nn,iproc)=ees0m(j,i)
6393             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6394             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6395             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6396             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6397             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6398             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6399             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6400             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6401             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6402             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6403             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6404             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6405             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6406             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6407             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6408             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6409             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6410             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6411             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6412             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6413             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6414           endif
6415         enddo
6416         enddo
6417       enddo
6418       if (lprn) then
6419       write (iout,*)
6420      &  "Numbers of contacts to be sent to other processors",
6421      &  (ncont_sent(i),i=1,ntask_cont_to)
6422       write (iout,*) "Contacts sent"
6423       do ii=1,ntask_cont_to
6424         nn=ncont_sent(ii)
6425         iproc=itask_cont_to(ii)
6426         write (iout,*) nn," contacts to processor",iproc,
6427      &   " of CONT_TO_COMM group"
6428         do i=1,nn
6429           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6430         enddo
6431       enddo
6432       call flush(iout)
6433       endif
6434       CorrelType=477
6435       CorrelID=fg_rank+1
6436       CorrelType1=478
6437       CorrelID1=nfgtasks+fg_rank+1
6438       ireq=0
6439 C Receive the numbers of needed contacts from other processors
6440       do ii=1,ntask_cont_from
6441         iproc=itask_cont_from(ii)
6442         ireq=ireq+1
6443         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6444      &    FG_COMM,req(ireq),IERR)
6445       enddo
6446 c      write (iout,*) "IRECV ended"
6447 c      call flush(iout)
6448 C Send the number of contacts needed by other processors
6449       do ii=1,ntask_cont_to
6450         iproc=itask_cont_to(ii)
6451         ireq=ireq+1
6452         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6453      &    FG_COMM,req(ireq),IERR)
6454       enddo
6455 c      write (iout,*) "ISEND ended"
6456 c      write (iout,*) "number of requests (nn)",ireq
6457       call flush(iout)
6458       if (ireq.gt.0)
6459      &  call MPI_Waitall(ireq,req,status_array,ierr)
6460 c      write (iout,*)
6461 c     &  "Numbers of contacts to be received from other processors",
6462 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6463 c      call flush(iout)
6464 C Receive contacts
6465       ireq=0
6466       do ii=1,ntask_cont_from
6467         iproc=itask_cont_from(ii)
6468         nn=ncont_recv(ii)
6469 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6470 c     &   " of CONT_TO_COMM group"
6471         call flush(iout)
6472         if (nn.gt.0) then
6473           ireq=ireq+1
6474           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6475      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6476 c          write (iout,*) "ireq,req",ireq,req(ireq)
6477         endif
6478       enddo
6479 C Send the contacts to processors that need them
6480       do ii=1,ntask_cont_to
6481         iproc=itask_cont_to(ii)
6482         nn=ncont_sent(ii)
6483 c        write (iout,*) nn," contacts to processor",iproc,
6484 c     &   " of CONT_TO_COMM group"
6485         if (nn.gt.0) then
6486           ireq=ireq+1
6487           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6488      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6489 c          write (iout,*) "ireq,req",ireq,req(ireq)
6490 c          do i=1,nn
6491 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6492 c          enddo
6493         endif
6494       enddo
6495 c      write (iout,*) "number of requests (contacts)",ireq
6496 c      write (iout,*) "req",(req(i),i=1,4)
6497 c      call flush(iout)
6498       if (ireq.gt.0)
6499      & call MPI_Waitall(ireq,req,status_array,ierr)
6500       do iii=1,ntask_cont_from
6501         iproc=itask_cont_from(iii)
6502         nn=ncont_recv(iii)
6503         if (lprn) then
6504         write (iout,*) "Received",nn," contacts from processor",iproc,
6505      &   " of CONT_FROM_COMM group"
6506         call flush(iout)
6507         do i=1,nn
6508           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6509         enddo
6510         call flush(iout)
6511         endif
6512         do i=1,nn
6513           ii=zapas_recv(1,i,iii)
6514 c Flag the received contacts to prevent double-counting
6515           jj=-zapas_recv(2,i,iii)
6516 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6517 c          call flush(iout)
6518           nnn=num_cont_hb(ii)+1
6519           num_cont_hb(ii)=nnn
6520           jcont_hb(nnn,ii)=jj
6521           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6522           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6523           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6524           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6525           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6526           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6527           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6528           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6529           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6530           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6531           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6532           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6533           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6534           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6535           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6536           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6537           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6538           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6539           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6540           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6541           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6542           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6543           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6544           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6545         enddo
6546       enddo
6547       call flush(iout)
6548       if (lprn) then
6549         write (iout,'(a)') 'Contact function values after receive:'
6550         do i=nnt,nct-2
6551           write (iout,'(2i3,50(1x,i3,f5.2))')
6552      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6553      &    j=1,num_cont_hb(i))
6554         enddo
6555         call flush(iout)
6556       endif
6557    30 continue
6558 #endif
6559       if (lprn) then
6560         write (iout,'(a)') 'Contact function values:'
6561         do i=nnt,nct-2
6562           write (iout,'(2i3,50(1x,i3,f5.2))')
6563      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6564      &    j=1,num_cont_hb(i))
6565         enddo
6566       endif
6567       ecorr=0.0D0
6568 C Remove the loop below after debugging !!!
6569       do i=nnt,nct
6570         do j=1,3
6571           gradcorr(j,i)=0.0D0
6572           gradxorr(j,i)=0.0D0
6573         enddo
6574       enddo
6575 C Calculate the local-electrostatic correlation terms
6576       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6577         i1=i+1
6578         num_conti=num_cont_hb(i)
6579         num_conti1=num_cont_hb(i+1)
6580         do jj=1,num_conti
6581           j=jcont_hb(jj,i)
6582           jp=iabs(j)
6583           do kk=1,num_conti1
6584             j1=jcont_hb(kk,i1)
6585             jp1=iabs(j1)
6586 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6587 c     &         ' jj=',jj,' kk=',kk
6588             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6589      &          .or. j.lt.0 .and. j1.gt.0) .and.
6590      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6591 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6592 C The system gains extra energy.
6593               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6594               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6595      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6596               n_corr=n_corr+1
6597             else if (j1.eq.j) then
6598 C Contacts I-J and I-(J+1) occur simultaneously.
6599 C The system loses extra energy.
6600 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6601             endif
6602           enddo ! kk
6603           do kk=1,num_conti
6604             j1=jcont_hb(kk,i)
6605 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6606 c    &         ' jj=',jj,' kk=',kk
6607             if (j1.eq.j+1) then
6608 C Contacts I-J and (I+1)-J occur simultaneously.
6609 C The system loses extra energy.
6610 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6611             endif ! j1==j+1
6612           enddo ! kk
6613         enddo ! jj
6614       enddo ! i
6615       return
6616       end
6617 c------------------------------------------------------------------------------
6618       subroutine add_hb_contact(ii,jj,itask)
6619       implicit real*8 (a-h,o-z)
6620       include "DIMENSIONS"
6621       include "COMMON.IOUNITS"
6622       integer max_cont
6623       integer max_dim
6624       parameter (max_cont=maxconts)
6625       parameter (max_dim=26)
6626       include "COMMON.CONTACTS"
6627       double precision zapas(max_dim,maxconts,max_fg_procs),
6628      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6629       common /przechowalnia/ zapas
6630       integer i,j,ii,jj,iproc,itask(4),nn
6631 c      write (iout,*) "itask",itask
6632       do i=1,2
6633         iproc=itask(i)
6634         if (iproc.gt.0) then
6635           do j=1,num_cont_hb(ii)
6636             jjc=jcont_hb(j,ii)
6637 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6638             if (jjc.eq.jj) then
6639               ncont_sent(iproc)=ncont_sent(iproc)+1
6640               nn=ncont_sent(iproc)
6641               zapas(1,nn,iproc)=ii
6642               zapas(2,nn,iproc)=jjc
6643               zapas(3,nn,iproc)=facont_hb(j,ii)
6644               zapas(4,nn,iproc)=ees0p(j,ii)
6645               zapas(5,nn,iproc)=ees0m(j,ii)
6646               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6647               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6648               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6649               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6650               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6651               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6652               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6653               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6654               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6655               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6656               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6657               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6658               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6659               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6660               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6661               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6662               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6663               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6664               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6665               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6666               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6667               exit
6668             endif
6669           enddo
6670         endif
6671       enddo
6672       return
6673       end
6674 c------------------------------------------------------------------------------
6675       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6676      &  n_corr1)
6677 C This subroutine calculates multi-body contributions to hydrogen-bonding
6678       implicit real*8 (a-h,o-z)
6679       include 'DIMENSIONS'
6680       include 'COMMON.IOUNITS'
6681 #ifdef MPI
6682       include "mpif.h"
6683       parameter (max_cont=maxconts)
6684       parameter (max_dim=70)
6685       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6686       double precision zapas(max_dim,maxconts,max_fg_procs),
6687      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6688       common /przechowalnia/ zapas
6689       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6690      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6691 #endif
6692       include 'COMMON.SETUP'
6693       include 'COMMON.FFIELD'
6694       include 'COMMON.DERIV'
6695       include 'COMMON.LOCAL'
6696       include 'COMMON.INTERACT'
6697       include 'COMMON.CONTACTS'
6698       include 'COMMON.CHAIN'
6699       include 'COMMON.CONTROL'
6700       double precision gx(3),gx1(3)
6701       integer num_cont_hb_old(maxres)
6702       logical lprn,ldone
6703       double precision eello4,eello5,eelo6,eello_turn6
6704       external eello4,eello5,eello6,eello_turn6
6705 C Set lprn=.true. for debugging
6706       lprn=.false.
6707       eturn6=0.0d0
6708 #ifdef MPI
6709       do i=1,nres
6710         num_cont_hb_old(i)=num_cont_hb(i)
6711       enddo
6712       n_corr=0
6713       n_corr1=0
6714       if (nfgtasks.le.1) goto 30
6715       if (lprn) then
6716         write (iout,'(a)') 'Contact function values before RECEIVE:'
6717         do i=nnt,nct-2
6718           write (iout,'(2i3,50(1x,i2,f5.2))')
6719      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6720      &    j=1,num_cont_hb(i))
6721         enddo
6722       endif
6723       call flush(iout)
6724       do i=1,ntask_cont_from
6725         ncont_recv(i)=0
6726       enddo
6727       do i=1,ntask_cont_to
6728         ncont_sent(i)=0
6729       enddo
6730 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6731 c     & ntask_cont_to
6732 C Make the list of contacts to send to send to other procesors
6733       do i=iturn3_start,iturn3_end
6734 c        write (iout,*) "make contact list turn3",i," num_cont",
6735 c     &    num_cont_hb(i)
6736         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6737       enddo
6738       do i=iturn4_start,iturn4_end
6739 c        write (iout,*) "make contact list turn4",i," num_cont",
6740 c     &   num_cont_hb(i)
6741         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6742       enddo
6743       do ii=1,nat_sent
6744         i=iat_sent(ii)
6745 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6746 c     &    num_cont_hb(i)
6747         do j=1,num_cont_hb(i)
6748         do k=1,4
6749           jjc=jcont_hb(j,i)
6750           iproc=iint_sent_local(k,jjc,ii)
6751 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6752           if (iproc.ne.0) then
6753             ncont_sent(iproc)=ncont_sent(iproc)+1
6754             nn=ncont_sent(iproc)
6755             zapas(1,nn,iproc)=i
6756             zapas(2,nn,iproc)=jjc
6757             zapas(3,nn,iproc)=d_cont(j,i)
6758             ind=3
6759             do kk=1,3
6760               ind=ind+1
6761               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6762             enddo
6763             do kk=1,2
6764               do ll=1,2
6765                 ind=ind+1
6766                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6767               enddo
6768             enddo
6769             do jj=1,5
6770               do kk=1,3
6771                 do ll=1,2
6772                   do mm=1,2
6773                     ind=ind+1
6774                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6775                   enddo
6776                 enddo
6777               enddo
6778             enddo
6779           endif
6780         enddo
6781         enddo
6782       enddo
6783       if (lprn) then
6784       write (iout,*)
6785      &  "Numbers of contacts to be sent to other processors",
6786      &  (ncont_sent(i),i=1,ntask_cont_to)
6787       write (iout,*) "Contacts sent"
6788       do ii=1,ntask_cont_to
6789         nn=ncont_sent(ii)
6790         iproc=itask_cont_to(ii)
6791         write (iout,*) nn," contacts to processor",iproc,
6792      &   " of CONT_TO_COMM group"
6793         do i=1,nn
6794           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6795         enddo
6796       enddo
6797       call flush(iout)
6798       endif
6799       CorrelType=477
6800       CorrelID=fg_rank+1
6801       CorrelType1=478
6802       CorrelID1=nfgtasks+fg_rank+1
6803       ireq=0
6804 C Receive the numbers of needed contacts from other processors
6805       do ii=1,ntask_cont_from
6806         iproc=itask_cont_from(ii)
6807         ireq=ireq+1
6808         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6809      &    FG_COMM,req(ireq),IERR)
6810       enddo
6811 c      write (iout,*) "IRECV ended"
6812 c      call flush(iout)
6813 C Send the number of contacts needed by other processors
6814       do ii=1,ntask_cont_to
6815         iproc=itask_cont_to(ii)
6816         ireq=ireq+1
6817         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6818      &    FG_COMM,req(ireq),IERR)
6819       enddo
6820 c      write (iout,*) "ISEND ended"
6821 c      write (iout,*) "number of requests (nn)",ireq
6822       call flush(iout)
6823       if (ireq.gt.0)
6824      &  call MPI_Waitall(ireq,req,status_array,ierr)
6825 c      write (iout,*)
6826 c     &  "Numbers of contacts to be received from other processors",
6827 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6828 c      call flush(iout)
6829 C Receive contacts
6830       ireq=0
6831       do ii=1,ntask_cont_from
6832         iproc=itask_cont_from(ii)
6833         nn=ncont_recv(ii)
6834 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6835 c     &   " of CONT_TO_COMM group"
6836         call flush(iout)
6837         if (nn.gt.0) then
6838           ireq=ireq+1
6839           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6840      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6841 c          write (iout,*) "ireq,req",ireq,req(ireq)
6842         endif
6843       enddo
6844 C Send the contacts to processors that need them
6845       do ii=1,ntask_cont_to
6846         iproc=itask_cont_to(ii)
6847         nn=ncont_sent(ii)
6848 c        write (iout,*) nn," contacts to processor",iproc,
6849 c     &   " of CONT_TO_COMM group"
6850         if (nn.gt.0) then
6851           ireq=ireq+1
6852           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6853      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6854 c          write (iout,*) "ireq,req",ireq,req(ireq)
6855 c          do i=1,nn
6856 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6857 c          enddo
6858         endif
6859       enddo
6860 c      write (iout,*) "number of requests (contacts)",ireq
6861 c      write (iout,*) "req",(req(i),i=1,4)
6862 c      call flush(iout)
6863       if (ireq.gt.0)
6864      & call MPI_Waitall(ireq,req,status_array,ierr)
6865       do iii=1,ntask_cont_from
6866         iproc=itask_cont_from(iii)
6867         nn=ncont_recv(iii)
6868         if (lprn) then
6869         write (iout,*) "Received",nn," contacts from processor",iproc,
6870      &   " of CONT_FROM_COMM group"
6871         call flush(iout)
6872         do i=1,nn
6873           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6874         enddo
6875         call flush(iout)
6876         endif
6877         do i=1,nn
6878           ii=zapas_recv(1,i,iii)
6879 c Flag the received contacts to prevent double-counting
6880           jj=-zapas_recv(2,i,iii)
6881 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6882 c          call flush(iout)
6883           nnn=num_cont_hb(ii)+1
6884           num_cont_hb(ii)=nnn
6885           jcont_hb(nnn,ii)=jj
6886           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6887           ind=3
6888           do kk=1,3
6889             ind=ind+1
6890             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6891           enddo
6892           do kk=1,2
6893             do ll=1,2
6894               ind=ind+1
6895               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6896             enddo
6897           enddo
6898           do jj=1,5
6899             do kk=1,3
6900               do ll=1,2
6901                 do mm=1,2
6902                   ind=ind+1
6903                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6904                 enddo
6905               enddo
6906             enddo
6907           enddo
6908         enddo
6909       enddo
6910       call flush(iout)
6911       if (lprn) then
6912         write (iout,'(a)') 'Contact function values after receive:'
6913         do i=nnt,nct-2
6914           write (iout,'(2i3,50(1x,i3,5f6.3))')
6915      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6916      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6917         enddo
6918         call flush(iout)
6919       endif
6920    30 continue
6921 #endif
6922       if (lprn) then
6923         write (iout,'(a)') 'Contact function values:'
6924         do i=nnt,nct-2
6925           write (iout,'(2i3,50(1x,i2,5f6.3))')
6926      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6927      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6928         enddo
6929       endif
6930       ecorr=0.0D0
6931       ecorr5=0.0d0
6932       ecorr6=0.0d0
6933 C Remove the loop below after debugging !!!
6934       do i=nnt,nct
6935         do j=1,3
6936           gradcorr(j,i)=0.0D0
6937           gradxorr(j,i)=0.0D0
6938         enddo
6939       enddo
6940 C Calculate the dipole-dipole interaction energies
6941       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6942       do i=iatel_s,iatel_e+1
6943         num_conti=num_cont_hb(i)
6944         do jj=1,num_conti
6945           j=jcont_hb(jj,i)
6946 #ifdef MOMENT
6947           call dipole(i,j,jj)
6948 #endif
6949         enddo
6950       enddo
6951       endif
6952 C Calculate the local-electrostatic correlation terms
6953 c                write (iout,*) "gradcorr5 in eello5 before loop"
6954 c                do iii=1,nres
6955 c                  write (iout,'(i5,3f10.5)')
6956 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6957 c                enddo
6958       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6959 c        write (iout,*) "corr loop i",i
6960         i1=i+1
6961         num_conti=num_cont_hb(i)
6962         num_conti1=num_cont_hb(i+1)
6963         do jj=1,num_conti
6964           j=jcont_hb(jj,i)
6965           jp=iabs(j)
6966           do kk=1,num_conti1
6967             j1=jcont_hb(kk,i1)
6968             jp1=iabs(j1)
6969 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6970 c     &         ' jj=',jj,' kk=',kk
6971 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6972             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6973      &          .or. j.lt.0 .and. j1.gt.0) .and.
6974      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6975 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6976 C The system gains extra energy.
6977               n_corr=n_corr+1
6978               sqd1=dsqrt(d_cont(jj,i))
6979               sqd2=dsqrt(d_cont(kk,i1))
6980               sred_geom = sqd1*sqd2
6981               IF (sred_geom.lt.cutoff_corr) THEN
6982                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6983      &            ekont,fprimcont)
6984 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6985 cd     &         ' jj=',jj,' kk=',kk
6986                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6987                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6988                 do l=1,3
6989                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6990                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6991                 enddo
6992                 n_corr1=n_corr1+1
6993 cd               write (iout,*) 'sred_geom=',sred_geom,
6994 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6995 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6996 cd               write (iout,*) "g_contij",g_contij
6997 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6998 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6999                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7000                 if (wcorr4.gt.0.0d0)
7001      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7002                   if (energy_dec.and.wcorr4.gt.0.0d0)
7003      1                 write (iout,'(a6,4i5,0pf7.3)')
7004      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7005 c                write (iout,*) "gradcorr5 before eello5"
7006 c                do iii=1,nres
7007 c                  write (iout,'(i5,3f10.5)')
7008 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7009 c                enddo
7010                 if (wcorr5.gt.0.0d0)
7011      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7012 c                write (iout,*) "gradcorr5 after eello5"
7013 c                do iii=1,nres
7014 c                  write (iout,'(i5,3f10.5)')
7015 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7016 c                enddo
7017                   if (energy_dec.and.wcorr5.gt.0.0d0)
7018      1                 write (iout,'(a6,4i5,0pf7.3)')
7019      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7020 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7021 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7022                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7023      &               .or. wturn6.eq.0.0d0))then
7024 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7025                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7026                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7027      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7028 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7029 cd     &            'ecorr6=',ecorr6
7030 cd                write (iout,'(4e15.5)') sred_geom,
7031 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7032 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7033 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7034                 else if (wturn6.gt.0.0d0
7035      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7036 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7037                   eturn6=eturn6+eello_turn6(i,jj,kk)
7038                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7039      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7040 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7041                 endif
7042               ENDIF
7043 1111          continue
7044             endif
7045           enddo ! kk
7046         enddo ! jj
7047       enddo ! i
7048       do i=1,nres
7049         num_cont_hb(i)=num_cont_hb_old(i)
7050       enddo
7051 c                write (iout,*) "gradcorr5 in eello5"
7052 c                do iii=1,nres
7053 c                  write (iout,'(i5,3f10.5)')
7054 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7055 c                enddo
7056       return
7057       end
7058 c------------------------------------------------------------------------------
7059       subroutine add_hb_contact_eello(ii,jj,itask)
7060       implicit real*8 (a-h,o-z)
7061       include "DIMENSIONS"
7062       include "COMMON.IOUNITS"
7063       integer max_cont
7064       integer max_dim
7065       parameter (max_cont=maxconts)
7066       parameter (max_dim=70)
7067       include "COMMON.CONTACTS"
7068       double precision zapas(max_dim,maxconts,max_fg_procs),
7069      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7070       common /przechowalnia/ zapas
7071       integer i,j,ii,jj,iproc,itask(4),nn
7072 c      write (iout,*) "itask",itask
7073       do i=1,2
7074         iproc=itask(i)
7075         if (iproc.gt.0) then
7076           do j=1,num_cont_hb(ii)
7077             jjc=jcont_hb(j,ii)
7078 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7079             if (jjc.eq.jj) then
7080               ncont_sent(iproc)=ncont_sent(iproc)+1
7081               nn=ncont_sent(iproc)
7082               zapas(1,nn,iproc)=ii
7083               zapas(2,nn,iproc)=jjc
7084               zapas(3,nn,iproc)=d_cont(j,ii)
7085               ind=3
7086               do kk=1,3
7087                 ind=ind+1
7088                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7089               enddo
7090               do kk=1,2
7091                 do ll=1,2
7092                   ind=ind+1
7093                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7094                 enddo
7095               enddo
7096               do jj=1,5
7097                 do kk=1,3
7098                   do ll=1,2
7099                     do mm=1,2
7100                       ind=ind+1
7101                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7102                     enddo
7103                   enddo
7104                 enddo
7105               enddo
7106               exit
7107             endif
7108           enddo
7109         endif
7110       enddo
7111       return
7112       end
7113 c------------------------------------------------------------------------------
7114       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7115       implicit real*8 (a-h,o-z)
7116       include 'DIMENSIONS'
7117       include 'COMMON.IOUNITS'
7118       include 'COMMON.DERIV'
7119       include 'COMMON.INTERACT'
7120       include 'COMMON.CONTACTS'
7121       double precision gx(3),gx1(3)
7122       logical lprn
7123       lprn=.false.
7124       eij=facont_hb(jj,i)
7125       ekl=facont_hb(kk,k)
7126       ees0pij=ees0p(jj,i)
7127       ees0pkl=ees0p(kk,k)
7128       ees0mij=ees0m(jj,i)
7129       ees0mkl=ees0m(kk,k)
7130       ekont=eij*ekl
7131       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7132 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7133 C Following 4 lines for diagnostics.
7134 cd    ees0pkl=0.0D0
7135 cd    ees0pij=1.0D0
7136 cd    ees0mkl=0.0D0
7137 cd    ees0mij=1.0D0
7138 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7139 c     & 'Contacts ',i,j,
7140 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7141 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7142 c     & 'gradcorr_long'
7143 C Calculate the multi-body contribution to energy.
7144 c      ecorr=ecorr+ekont*ees
7145 C Calculate multi-body contributions to the gradient.
7146       coeffpees0pij=coeffp*ees0pij
7147       coeffmees0mij=coeffm*ees0mij
7148       coeffpees0pkl=coeffp*ees0pkl
7149       coeffmees0mkl=coeffm*ees0mkl
7150       do ll=1,3
7151 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7152         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7153      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7154      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7155         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7156      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7157      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7158 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7159         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7160      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7161      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7162         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7163      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7164      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7165         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7166      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7167      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7168         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7169         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7170         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7171      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7172      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7173         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7174         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7175 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7176       enddo
7177 c      write (iout,*)
7178 cgrad      do m=i+1,j-1
7179 cgrad        do ll=1,3
7180 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7181 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7182 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7183 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7184 cgrad        enddo
7185 cgrad      enddo
7186 cgrad      do m=k+1,l-1
7187 cgrad        do ll=1,3
7188 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7189 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7190 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7191 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7192 cgrad        enddo
7193 cgrad      enddo
7194 c      write (iout,*) "ehbcorr",ekont*ees
7195       ehbcorr=ekont*ees
7196       return
7197       end
7198 #ifdef MOMENT
7199 C---------------------------------------------------------------------------
7200       subroutine dipole(i,j,jj)
7201       implicit real*8 (a-h,o-z)
7202       include 'DIMENSIONS'
7203       include 'COMMON.IOUNITS'
7204       include 'COMMON.CHAIN'
7205       include 'COMMON.FFIELD'
7206       include 'COMMON.DERIV'
7207       include 'COMMON.INTERACT'
7208       include 'COMMON.CONTACTS'
7209       include 'COMMON.TORSION'
7210       include 'COMMON.VAR'
7211       include 'COMMON.GEO'
7212       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7213      &  auxmat(2,2)
7214       iti1 = itortyp(itype(i+1))
7215       if (j.lt.nres-1) then
7216         itj1 = itortyp(itype(j+1))
7217       else
7218         itj1=ntortyp+1
7219       endif
7220       do iii=1,2
7221         dipi(iii,1)=Ub2(iii,i)
7222         dipderi(iii)=Ub2der(iii,i)
7223         dipi(iii,2)=b1(iii,iti1)
7224         dipj(iii,1)=Ub2(iii,j)
7225         dipderj(iii)=Ub2der(iii,j)
7226         dipj(iii,2)=b1(iii,itj1)
7227       enddo
7228       kkk=0
7229       do iii=1,2
7230         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7231         do jjj=1,2
7232           kkk=kkk+1
7233           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7234         enddo
7235       enddo
7236       do kkk=1,5
7237         do lll=1,3
7238           mmm=0
7239           do iii=1,2
7240             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7241      &        auxvec(1))
7242             do jjj=1,2
7243               mmm=mmm+1
7244               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7245             enddo
7246           enddo
7247         enddo
7248       enddo
7249       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7250       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7251       do iii=1,2
7252         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7253       enddo
7254       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7255       do iii=1,2
7256         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7257       enddo
7258       return
7259       end
7260 #endif
7261 C---------------------------------------------------------------------------
7262       subroutine calc_eello(i,j,k,l,jj,kk)
7263 C
7264 C This subroutine computes matrices and vectors needed to calculate
7265 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7266 C
7267       implicit real*8 (a-h,o-z)
7268       include 'DIMENSIONS'
7269       include 'COMMON.IOUNITS'
7270       include 'COMMON.CHAIN'
7271       include 'COMMON.DERIV'
7272       include 'COMMON.INTERACT'
7273       include 'COMMON.CONTACTS'
7274       include 'COMMON.TORSION'
7275       include 'COMMON.VAR'
7276       include 'COMMON.GEO'
7277       include 'COMMON.FFIELD'
7278       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7279      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7280       logical lprn
7281       common /kutas/ lprn
7282 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7283 cd     & ' jj=',jj,' kk=',kk
7284 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7285 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7286 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7287       do iii=1,2
7288         do jjj=1,2
7289           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7290           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7291         enddo
7292       enddo
7293       call transpose2(aa1(1,1),aa1t(1,1))
7294       call transpose2(aa2(1,1),aa2t(1,1))
7295       do kkk=1,5
7296         do lll=1,3
7297           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7298      &      aa1tder(1,1,lll,kkk))
7299           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7300      &      aa2tder(1,1,lll,kkk))
7301         enddo
7302       enddo
7303       if (l.eq.j+1) then
7304 C parallel orientation of the two CA-CA-CA frames.
7305         if (i.gt.1) then
7306           iti=itortyp(itype(i))
7307         else
7308           iti=ntortyp+1
7309         endif
7310         itk1=itortyp(itype(k+1))
7311         itj=itortyp(itype(j))
7312         if (l.lt.nres-1) then
7313           itl1=itortyp(itype(l+1))
7314         else
7315           itl1=ntortyp+1
7316         endif
7317 C A1 kernel(j+1) A2T
7318 cd        do iii=1,2
7319 cd          write (iout,'(3f10.5,5x,3f10.5)')
7320 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7321 cd        enddo
7322         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7323      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7324      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7325 C Following matrices are needed only for 6-th order cumulants
7326         IF (wcorr6.gt.0.0d0) THEN
7327         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7328      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7329      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7330         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7331      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7332      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7333      &   ADtEAderx(1,1,1,1,1,1))
7334         lprn=.false.
7335         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7336      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7337      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7338      &   ADtEA1derx(1,1,1,1,1,1))
7339         ENDIF
7340 C End 6-th order cumulants
7341 cd        lprn=.false.
7342 cd        if (lprn) then
7343 cd        write (2,*) 'In calc_eello6'
7344 cd        do iii=1,2
7345 cd          write (2,*) 'iii=',iii
7346 cd          do kkk=1,5
7347 cd            write (2,*) 'kkk=',kkk
7348 cd            do jjj=1,2
7349 cd              write (2,'(3(2f10.5),5x)')
7350 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7351 cd            enddo
7352 cd          enddo
7353 cd        enddo
7354 cd        endif
7355         call transpose2(EUgder(1,1,k),auxmat(1,1))
7356         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7357         call transpose2(EUg(1,1,k),auxmat(1,1))
7358         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7359         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7360         do iii=1,2
7361           do kkk=1,5
7362             do lll=1,3
7363               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7364      &          EAEAderx(1,1,lll,kkk,iii,1))
7365             enddo
7366           enddo
7367         enddo
7368 C A1T kernel(i+1) A2
7369         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7370      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7371      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7372 C Following matrices are needed only for 6-th order cumulants
7373         IF (wcorr6.gt.0.0d0) THEN
7374         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7375      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7376      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7377         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7378      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7379      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7380      &   ADtEAderx(1,1,1,1,1,2))
7381         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7382      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7383      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7384      &   ADtEA1derx(1,1,1,1,1,2))
7385         ENDIF
7386 C End 6-th order cumulants
7387         call transpose2(EUgder(1,1,l),auxmat(1,1))
7388         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7389         call transpose2(EUg(1,1,l),auxmat(1,1))
7390         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7391         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7392         do iii=1,2
7393           do kkk=1,5
7394             do lll=1,3
7395               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7396      &          EAEAderx(1,1,lll,kkk,iii,2))
7397             enddo
7398           enddo
7399         enddo
7400 C AEAb1 and AEAb2
7401 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7402 C They are needed only when the fifth- or the sixth-order cumulants are
7403 C indluded.
7404         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7405         call transpose2(AEA(1,1,1),auxmat(1,1))
7406         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7407         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7408         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7409         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7410         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7411         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7412         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7413         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7414         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7415         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7416         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7417         call transpose2(AEA(1,1,2),auxmat(1,1))
7418         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7419         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7420         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7421         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7422         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7423         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7424         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7425         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7426         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7427         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7428         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7429 C Calculate the Cartesian derivatives of the vectors.
7430         do iii=1,2
7431           do kkk=1,5
7432             do lll=1,3
7433               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7434               call matvec2(auxmat(1,1),b1(1,iti),
7435      &          AEAb1derx(1,lll,kkk,iii,1,1))
7436               call matvec2(auxmat(1,1),Ub2(1,i),
7437      &          AEAb2derx(1,lll,kkk,iii,1,1))
7438               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7439      &          AEAb1derx(1,lll,kkk,iii,2,1))
7440               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7441      &          AEAb2derx(1,lll,kkk,iii,2,1))
7442               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7443               call matvec2(auxmat(1,1),b1(1,itj),
7444      &          AEAb1derx(1,lll,kkk,iii,1,2))
7445               call matvec2(auxmat(1,1),Ub2(1,j),
7446      &          AEAb2derx(1,lll,kkk,iii,1,2))
7447               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7448      &          AEAb1derx(1,lll,kkk,iii,2,2))
7449               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7450      &          AEAb2derx(1,lll,kkk,iii,2,2))
7451             enddo
7452           enddo
7453         enddo
7454         ENDIF
7455 C End vectors
7456       else
7457 C Antiparallel orientation of the two CA-CA-CA frames.
7458         if (i.gt.1) then
7459           iti=itortyp(itype(i))
7460         else
7461           iti=ntortyp+1
7462         endif
7463         itk1=itortyp(itype(k+1))
7464         itl=itortyp(itype(l))
7465         itj=itortyp(itype(j))
7466         if (j.lt.nres-1) then
7467           itj1=itortyp(itype(j+1))
7468         else
7469           itj1=ntortyp+1
7470         endif
7471 C A2 kernel(j-1)T A1T
7472         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7473      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7474      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7475 C Following matrices are needed only for 6-th order cumulants
7476         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7477      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7478         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7479      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7480      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7481         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7482      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7483      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7484      &   ADtEAderx(1,1,1,1,1,1))
7485         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7486      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7487      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7488      &   ADtEA1derx(1,1,1,1,1,1))
7489         ENDIF
7490 C End 6-th order cumulants
7491         call transpose2(EUgder(1,1,k),auxmat(1,1))
7492         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7493         call transpose2(EUg(1,1,k),auxmat(1,1))
7494         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7495         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7496         do iii=1,2
7497           do kkk=1,5
7498             do lll=1,3
7499               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7500      &          EAEAderx(1,1,lll,kkk,iii,1))
7501             enddo
7502           enddo
7503         enddo
7504 C A2T kernel(i+1)T A1
7505         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7506      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7507      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7508 C Following matrices are needed only for 6-th order cumulants
7509         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7510      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7511         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7512      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7513      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7514         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7515      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7516      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7517      &   ADtEAderx(1,1,1,1,1,2))
7518         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7519      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7520      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7521      &   ADtEA1derx(1,1,1,1,1,2))
7522         ENDIF
7523 C End 6-th order cumulants
7524         call transpose2(EUgder(1,1,j),auxmat(1,1))
7525         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7526         call transpose2(EUg(1,1,j),auxmat(1,1))
7527         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7528         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7529         do iii=1,2
7530           do kkk=1,5
7531             do lll=1,3
7532               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7533      &          EAEAderx(1,1,lll,kkk,iii,2))
7534             enddo
7535           enddo
7536         enddo
7537 C AEAb1 and AEAb2
7538 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7539 C They are needed only when the fifth- or the sixth-order cumulants are
7540 C indluded.
7541         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7542      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7543         call transpose2(AEA(1,1,1),auxmat(1,1))
7544         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7545         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7546         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7547         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7548         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7549         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7550         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7551         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7552         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7553         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7554         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7555         call transpose2(AEA(1,1,2),auxmat(1,1))
7556         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7557         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7558         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7559         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7560         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7561         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7562         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7563         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7564         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7565         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7566         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7567 C Calculate the Cartesian derivatives of the vectors.
7568         do iii=1,2
7569           do kkk=1,5
7570             do lll=1,3
7571               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7572               call matvec2(auxmat(1,1),b1(1,iti),
7573      &          AEAb1derx(1,lll,kkk,iii,1,1))
7574               call matvec2(auxmat(1,1),Ub2(1,i),
7575      &          AEAb2derx(1,lll,kkk,iii,1,1))
7576               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7577      &          AEAb1derx(1,lll,kkk,iii,2,1))
7578               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7579      &          AEAb2derx(1,lll,kkk,iii,2,1))
7580               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7581               call matvec2(auxmat(1,1),b1(1,itl),
7582      &          AEAb1derx(1,lll,kkk,iii,1,2))
7583               call matvec2(auxmat(1,1),Ub2(1,l),
7584      &          AEAb2derx(1,lll,kkk,iii,1,2))
7585               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7586      &          AEAb1derx(1,lll,kkk,iii,2,2))
7587               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7588      &          AEAb2derx(1,lll,kkk,iii,2,2))
7589             enddo
7590           enddo
7591         enddo
7592         ENDIF
7593 C End vectors
7594       endif
7595       return
7596       end
7597 C---------------------------------------------------------------------------
7598       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7599      &  KK,KKderg,AKA,AKAderg,AKAderx)
7600       implicit none
7601       integer nderg
7602       logical transp
7603       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7604      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7605      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7606       integer iii,kkk,lll
7607       integer jjj,mmm
7608       logical lprn
7609       common /kutas/ lprn
7610       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7611       do iii=1,nderg
7612         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7613      &    AKAderg(1,1,iii))
7614       enddo
7615 cd      if (lprn) write (2,*) 'In kernel'
7616       do kkk=1,5
7617 cd        if (lprn) write (2,*) 'kkk=',kkk
7618         do lll=1,3
7619           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7620      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7621 cd          if (lprn) then
7622 cd            write (2,*) 'lll=',lll
7623 cd            write (2,*) 'iii=1'
7624 cd            do jjj=1,2
7625 cd              write (2,'(3(2f10.5),5x)')
7626 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7627 cd            enddo
7628 cd          endif
7629           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7630      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7631 cd          if (lprn) then
7632 cd            write (2,*) 'lll=',lll
7633 cd            write (2,*) 'iii=2'
7634 cd            do jjj=1,2
7635 cd              write (2,'(3(2f10.5),5x)')
7636 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7637 cd            enddo
7638 cd          endif
7639         enddo
7640       enddo
7641       return
7642       end
7643 C---------------------------------------------------------------------------
7644       double precision function eello4(i,j,k,l,jj,kk)
7645       implicit real*8 (a-h,o-z)
7646       include 'DIMENSIONS'
7647       include 'COMMON.IOUNITS'
7648       include 'COMMON.CHAIN'
7649       include 'COMMON.DERIV'
7650       include 'COMMON.INTERACT'
7651       include 'COMMON.CONTACTS'
7652       include 'COMMON.TORSION'
7653       include 'COMMON.VAR'
7654       include 'COMMON.GEO'
7655       double precision pizda(2,2),ggg1(3),ggg2(3)
7656 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7657 cd        eello4=0.0d0
7658 cd        return
7659 cd      endif
7660 cd      print *,'eello4:',i,j,k,l,jj,kk
7661 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7662 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7663 cold      eij=facont_hb(jj,i)
7664 cold      ekl=facont_hb(kk,k)
7665 cold      ekont=eij*ekl
7666       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7667 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7668       gcorr_loc(k-1)=gcorr_loc(k-1)
7669      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7670       if (l.eq.j+1) then
7671         gcorr_loc(l-1)=gcorr_loc(l-1)
7672      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7673       else
7674         gcorr_loc(j-1)=gcorr_loc(j-1)
7675      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7676       endif
7677       do iii=1,2
7678         do kkk=1,5
7679           do lll=1,3
7680             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7681      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7682 cd            derx(lll,kkk,iii)=0.0d0
7683           enddo
7684         enddo
7685       enddo
7686 cd      gcorr_loc(l-1)=0.0d0
7687 cd      gcorr_loc(j-1)=0.0d0
7688 cd      gcorr_loc(k-1)=0.0d0
7689 cd      eel4=1.0d0
7690 cd      write (iout,*)'Contacts have occurred for peptide groups',
7691 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7692 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7693       if (j.lt.nres-1) then
7694         j1=j+1
7695         j2=j-1
7696       else
7697         j1=j-1
7698         j2=j-2
7699       endif
7700       if (l.lt.nres-1) then
7701         l1=l+1
7702         l2=l-1
7703       else
7704         l1=l-1
7705         l2=l-2
7706       endif
7707       do ll=1,3
7708 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7709 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7710         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7711         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7712 cgrad        ghalf=0.5d0*ggg1(ll)
7713         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7714         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7715         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7716         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7717         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7718         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7719 cgrad        ghalf=0.5d0*ggg2(ll)
7720         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7721         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7722         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7723         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7724         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7725         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7726       enddo
7727 cgrad      do m=i+1,j-1
7728 cgrad        do ll=1,3
7729 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7730 cgrad        enddo
7731 cgrad      enddo
7732 cgrad      do m=k+1,l-1
7733 cgrad        do ll=1,3
7734 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7735 cgrad        enddo
7736 cgrad      enddo
7737 cgrad      do m=i+2,j2
7738 cgrad        do ll=1,3
7739 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7740 cgrad        enddo
7741 cgrad      enddo
7742 cgrad      do m=k+2,l2
7743 cgrad        do ll=1,3
7744 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7745 cgrad        enddo
7746 cgrad      enddo
7747 cd      do iii=1,nres-3
7748 cd        write (2,*) iii,gcorr_loc(iii)
7749 cd      enddo
7750       eello4=ekont*eel4
7751 cd      write (2,*) 'ekont',ekont
7752 cd      write (iout,*) 'eello4',ekont*eel4
7753       return
7754       end
7755 C---------------------------------------------------------------------------
7756       double precision function eello5(i,j,k,l,jj,kk)
7757       implicit real*8 (a-h,o-z)
7758       include 'DIMENSIONS'
7759       include 'COMMON.IOUNITS'
7760       include 'COMMON.CHAIN'
7761       include 'COMMON.DERIV'
7762       include 'COMMON.INTERACT'
7763       include 'COMMON.CONTACTS'
7764       include 'COMMON.TORSION'
7765       include 'COMMON.VAR'
7766       include 'COMMON.GEO'
7767       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7768       double precision ggg1(3),ggg2(3)
7769 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7770 C                                                                              C
7771 C                            Parallel chains                                   C
7772 C                                                                              C
7773 C          o             o                   o             o                   C
7774 C         /l\           / \             \   / \           / \   /              C
7775 C        /   \         /   \             \ /   \         /   \ /               C
7776 C       j| o |l1       | o |              o| o |         | o |o                C
7777 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7778 C      \i/   \         /   \ /             /   \         /   \                 C
7779 C       o    k1             o                                                  C
7780 C         (I)          (II)                (III)          (IV)                 C
7781 C                                                                              C
7782 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7783 C                                                                              C
7784 C                            Antiparallel chains                               C
7785 C                                                                              C
7786 C          o             o                   o             o                   C
7787 C         /j\           / \             \   / \           / \   /              C
7788 C        /   \         /   \             \ /   \         /   \ /               C
7789 C      j1| o |l        | o |              o| o |         | o |o                C
7790 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7791 C      \i/   \         /   \ /             /   \         /   \                 C
7792 C       o     k1            o                                                  C
7793 C         (I)          (II)                (III)          (IV)                 C
7794 C                                                                              C
7795 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7796 C                                                                              C
7797 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7798 C                                                                              C
7799 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7800 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7801 cd        eello5=0.0d0
7802 cd        return
7803 cd      endif
7804 cd      write (iout,*)
7805 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7806 cd     &   ' and',k,l
7807       itk=itortyp(itype(k))
7808       itl=itortyp(itype(l))
7809       itj=itortyp(itype(j))
7810       eello5_1=0.0d0
7811       eello5_2=0.0d0
7812       eello5_3=0.0d0
7813       eello5_4=0.0d0
7814 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7815 cd     &   eel5_3_num,eel5_4_num)
7816       do iii=1,2
7817         do kkk=1,5
7818           do lll=1,3
7819             derx(lll,kkk,iii)=0.0d0
7820           enddo
7821         enddo
7822       enddo
7823 cd      eij=facont_hb(jj,i)
7824 cd      ekl=facont_hb(kk,k)
7825 cd      ekont=eij*ekl
7826 cd      write (iout,*)'Contacts have occurred for peptide groups',
7827 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7828 cd      goto 1111
7829 C Contribution from the graph I.
7830 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7831 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7832       call transpose2(EUg(1,1,k),auxmat(1,1))
7833       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7834       vv(1)=pizda(1,1)-pizda(2,2)
7835       vv(2)=pizda(1,2)+pizda(2,1)
7836       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7837      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7838 C Explicit gradient in virtual-dihedral angles.
7839       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7840      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7841      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7842       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7843       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7844       vv(1)=pizda(1,1)-pizda(2,2)
7845       vv(2)=pizda(1,2)+pizda(2,1)
7846       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7847      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7848      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7849       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7850       vv(1)=pizda(1,1)-pizda(2,2)
7851       vv(2)=pizda(1,2)+pizda(2,1)
7852       if (l.eq.j+1) then
7853         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7854      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7855      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7856       else
7857         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7858      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7859      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7860       endif
7861 C Cartesian gradient
7862       do iii=1,2
7863         do kkk=1,5
7864           do lll=1,3
7865             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7866      &        pizda(1,1))
7867             vv(1)=pizda(1,1)-pizda(2,2)
7868             vv(2)=pizda(1,2)+pizda(2,1)
7869             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7870      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7871      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7872           enddo
7873         enddo
7874       enddo
7875 c      goto 1112
7876 c1111  continue
7877 C Contribution from graph II
7878       call transpose2(EE(1,1,itk),auxmat(1,1))
7879       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7880       vv(1)=pizda(1,1)+pizda(2,2)
7881       vv(2)=pizda(2,1)-pizda(1,2)
7882       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7883      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7884 C Explicit gradient in virtual-dihedral angles.
7885       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7886      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7887       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7888       vv(1)=pizda(1,1)+pizda(2,2)
7889       vv(2)=pizda(2,1)-pizda(1,2)
7890       if (l.eq.j+1) then
7891         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7892      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7893      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7894       else
7895         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7896      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7897      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7898       endif
7899 C Cartesian gradient
7900       do iii=1,2
7901         do kkk=1,5
7902           do lll=1,3
7903             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7904      &        pizda(1,1))
7905             vv(1)=pizda(1,1)+pizda(2,2)
7906             vv(2)=pizda(2,1)-pizda(1,2)
7907             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7908      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7909      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7910           enddo
7911         enddo
7912       enddo
7913 cd      goto 1112
7914 cd1111  continue
7915       if (l.eq.j+1) then
7916 cd        goto 1110
7917 C Parallel orientation
7918 C Contribution from graph III
7919         call transpose2(EUg(1,1,l),auxmat(1,1))
7920         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7921         vv(1)=pizda(1,1)-pizda(2,2)
7922         vv(2)=pizda(1,2)+pizda(2,1)
7923         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7924      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7925 C Explicit gradient in virtual-dihedral angles.
7926         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7927      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7928      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7929         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7930         vv(1)=pizda(1,1)-pizda(2,2)
7931         vv(2)=pizda(1,2)+pizda(2,1)
7932         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7933      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7934      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7935         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7936         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7937         vv(1)=pizda(1,1)-pizda(2,2)
7938         vv(2)=pizda(1,2)+pizda(2,1)
7939         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7940      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7941      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7942 C Cartesian gradient
7943         do iii=1,2
7944           do kkk=1,5
7945             do lll=1,3
7946               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7947      &          pizda(1,1))
7948               vv(1)=pizda(1,1)-pizda(2,2)
7949               vv(2)=pizda(1,2)+pizda(2,1)
7950               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7951      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7952      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7953             enddo
7954           enddo
7955         enddo
7956 cd        goto 1112
7957 C Contribution from graph IV
7958 cd1110    continue
7959         call transpose2(EE(1,1,itl),auxmat(1,1))
7960         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7961         vv(1)=pizda(1,1)+pizda(2,2)
7962         vv(2)=pizda(2,1)-pizda(1,2)
7963         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7964      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7965 C Explicit gradient in virtual-dihedral angles.
7966         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7967      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7968         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7969         vv(1)=pizda(1,1)+pizda(2,2)
7970         vv(2)=pizda(2,1)-pizda(1,2)
7971         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7972      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7973      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7974 C Cartesian gradient
7975         do iii=1,2
7976           do kkk=1,5
7977             do lll=1,3
7978               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7979      &          pizda(1,1))
7980               vv(1)=pizda(1,1)+pizda(2,2)
7981               vv(2)=pizda(2,1)-pizda(1,2)
7982               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7983      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7984      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7985             enddo
7986           enddo
7987         enddo
7988       else
7989 C Antiparallel orientation
7990 C Contribution from graph III
7991 c        goto 1110
7992         call transpose2(EUg(1,1,j),auxmat(1,1))
7993         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7994         vv(1)=pizda(1,1)-pizda(2,2)
7995         vv(2)=pizda(1,2)+pizda(2,1)
7996         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7997      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7998 C Explicit gradient in virtual-dihedral angles.
7999         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8000      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8001      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8002         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8003         vv(1)=pizda(1,1)-pizda(2,2)
8004         vv(2)=pizda(1,2)+pizda(2,1)
8005         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8006      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8007      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8008         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8009         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8010         vv(1)=pizda(1,1)-pizda(2,2)
8011         vv(2)=pizda(1,2)+pizda(2,1)
8012         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8013      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8014      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8015 C Cartesian gradient
8016         do iii=1,2
8017           do kkk=1,5
8018             do lll=1,3
8019               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8020      &          pizda(1,1))
8021               vv(1)=pizda(1,1)-pizda(2,2)
8022               vv(2)=pizda(1,2)+pizda(2,1)
8023               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8024      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8025      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8026             enddo
8027           enddo
8028         enddo
8029 cd        goto 1112
8030 C Contribution from graph IV
8031 1110    continue
8032         call transpose2(EE(1,1,itj),auxmat(1,1))
8033         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8034         vv(1)=pizda(1,1)+pizda(2,2)
8035         vv(2)=pizda(2,1)-pizda(1,2)
8036         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8037      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8038 C Explicit gradient in virtual-dihedral angles.
8039         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8040      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8041         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8042         vv(1)=pizda(1,1)+pizda(2,2)
8043         vv(2)=pizda(2,1)-pizda(1,2)
8044         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8045      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8046      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8047 C Cartesian gradient
8048         do iii=1,2
8049           do kkk=1,5
8050             do lll=1,3
8051               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8052      &          pizda(1,1))
8053               vv(1)=pizda(1,1)+pizda(2,2)
8054               vv(2)=pizda(2,1)-pizda(1,2)
8055               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8056      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8057      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8058             enddo
8059           enddo
8060         enddo
8061       endif
8062 1112  continue
8063       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8064 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8065 cd        write (2,*) 'ijkl',i,j,k,l
8066 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8067 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8068 cd      endif
8069 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8070 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8071 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8072 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8073       if (j.lt.nres-1) then
8074         j1=j+1
8075         j2=j-1
8076       else
8077         j1=j-1
8078         j2=j-2
8079       endif
8080       if (l.lt.nres-1) then
8081         l1=l+1
8082         l2=l-1
8083       else
8084         l1=l-1
8085         l2=l-2
8086       endif
8087 cd      eij=1.0d0
8088 cd      ekl=1.0d0
8089 cd      ekont=1.0d0
8090 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8091 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8092 C        summed up outside the subrouine as for the other subroutines
8093 C        handling long-range interactions. The old code is commented out
8094 C        with "cgrad" to keep track of changes.
8095       do ll=1,3
8096 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8097 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8098         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8099         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8100 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8101 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8102 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8103 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8104 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8105 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8106 c     &   gradcorr5ij,
8107 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8108 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8109 cgrad        ghalf=0.5d0*ggg1(ll)
8110 cd        ghalf=0.0d0
8111         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8112         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8113         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8114         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8115         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8116         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8117 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8118 cgrad        ghalf=0.5d0*ggg2(ll)
8119 cd        ghalf=0.0d0
8120         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8121         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8122         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8123         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8124         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8125         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8126       enddo
8127 cd      goto 1112
8128 cgrad      do m=i+1,j-1
8129 cgrad        do ll=1,3
8130 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8131 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8132 cgrad        enddo
8133 cgrad      enddo
8134 cgrad      do m=k+1,l-1
8135 cgrad        do ll=1,3
8136 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8137 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8138 cgrad        enddo
8139 cgrad      enddo
8140 c1112  continue
8141 cgrad      do m=i+2,j2
8142 cgrad        do ll=1,3
8143 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8144 cgrad        enddo
8145 cgrad      enddo
8146 cgrad      do m=k+2,l2
8147 cgrad        do ll=1,3
8148 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8149 cgrad        enddo
8150 cgrad      enddo
8151 cd      do iii=1,nres-3
8152 cd        write (2,*) iii,g_corr5_loc(iii)
8153 cd      enddo
8154       eello5=ekont*eel5
8155 cd      write (2,*) 'ekont',ekont
8156 cd      write (iout,*) 'eello5',ekont*eel5
8157       return
8158       end
8159 c--------------------------------------------------------------------------
8160       double precision function eello6(i,j,k,l,jj,kk)
8161       implicit real*8 (a-h,o-z)
8162       include 'DIMENSIONS'
8163       include 'COMMON.IOUNITS'
8164       include 'COMMON.CHAIN'
8165       include 'COMMON.DERIV'
8166       include 'COMMON.INTERACT'
8167       include 'COMMON.CONTACTS'
8168       include 'COMMON.TORSION'
8169       include 'COMMON.VAR'
8170       include 'COMMON.GEO'
8171       include 'COMMON.FFIELD'
8172       double precision ggg1(3),ggg2(3)
8173 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8174 cd        eello6=0.0d0
8175 cd        return
8176 cd      endif
8177 cd      write (iout,*)
8178 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8179 cd     &   ' and',k,l
8180       eello6_1=0.0d0
8181       eello6_2=0.0d0
8182       eello6_3=0.0d0
8183       eello6_4=0.0d0
8184       eello6_5=0.0d0
8185       eello6_6=0.0d0
8186 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8187 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8188       do iii=1,2
8189         do kkk=1,5
8190           do lll=1,3
8191             derx(lll,kkk,iii)=0.0d0
8192           enddo
8193         enddo
8194       enddo
8195 cd      eij=facont_hb(jj,i)
8196 cd      ekl=facont_hb(kk,k)
8197 cd      ekont=eij*ekl
8198 cd      eij=1.0d0
8199 cd      ekl=1.0d0
8200 cd      ekont=1.0d0
8201       if (l.eq.j+1) then
8202         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8203         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8204         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8205         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8206         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8207         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8208       else
8209         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8210         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8211         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8212         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8213         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8214           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8215         else
8216           eello6_5=0.0d0
8217         endif
8218         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8219       endif
8220 C If turn contributions are considered, they will be handled separately.
8221       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8222 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8223 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8224 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8225 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8226 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8227 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8228 cd      goto 1112
8229       if (j.lt.nres-1) then
8230         j1=j+1
8231         j2=j-1
8232       else
8233         j1=j-1
8234         j2=j-2
8235       endif
8236       if (l.lt.nres-1) then
8237         l1=l+1
8238         l2=l-1
8239       else
8240         l1=l-1
8241         l2=l-2
8242       endif
8243       do ll=1,3
8244 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8245 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8246 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8247 cgrad        ghalf=0.5d0*ggg1(ll)
8248 cd        ghalf=0.0d0
8249         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8250         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8251         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8252         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8253         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8254         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8255         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8256         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8257 cgrad        ghalf=0.5d0*ggg2(ll)
8258 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8259 cd        ghalf=0.0d0
8260         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8261         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8262         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8263         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8264         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8265         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8266       enddo
8267 cd      goto 1112
8268 cgrad      do m=i+1,j-1
8269 cgrad        do ll=1,3
8270 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8271 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8272 cgrad        enddo
8273 cgrad      enddo
8274 cgrad      do m=k+1,l-1
8275 cgrad        do ll=1,3
8276 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8277 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8278 cgrad        enddo
8279 cgrad      enddo
8280 cgrad1112  continue
8281 cgrad      do m=i+2,j2
8282 cgrad        do ll=1,3
8283 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8284 cgrad        enddo
8285 cgrad      enddo
8286 cgrad      do m=k+2,l2
8287 cgrad        do ll=1,3
8288 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8289 cgrad        enddo
8290 cgrad      enddo
8291 cd      do iii=1,nres-3
8292 cd        write (2,*) iii,g_corr6_loc(iii)
8293 cd      enddo
8294       eello6=ekont*eel6
8295 cd      write (2,*) 'ekont',ekont
8296 cd      write (iout,*) 'eello6',ekont*eel6
8297       return
8298       end
8299 c--------------------------------------------------------------------------
8300       double precision function eello6_graph1(i,j,k,l,imat,swap)
8301       implicit real*8 (a-h,o-z)
8302       include 'DIMENSIONS'
8303       include 'COMMON.IOUNITS'
8304       include 'COMMON.CHAIN'
8305       include 'COMMON.DERIV'
8306       include 'COMMON.INTERACT'
8307       include 'COMMON.CONTACTS'
8308       include 'COMMON.TORSION'
8309       include 'COMMON.VAR'
8310       include 'COMMON.GEO'
8311       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8312       logical swap
8313       logical lprn
8314       common /kutas/ lprn
8315 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8316 C
8317 C      Parallel       Antiparallel
8318 C
8319 C          o             o
8320 C         /l\           /j\
8321 C        /   \         /   \
8322 C       /| o |         | o |\
8323 C     \ j|/k\|  /   \  |/k\|l /
8324 C      \ /   \ /     \ /   \ /
8325 C       o     o       o     o
8326 C       i             i
8327 C
8328 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8329       itk=itortyp(itype(k))
8330       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8331       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8332       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8333       call transpose2(EUgC(1,1,k),auxmat(1,1))
8334       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8335       vv1(1)=pizda1(1,1)-pizda1(2,2)
8336       vv1(2)=pizda1(1,2)+pizda1(2,1)
8337       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8338       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8339       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8340       s5=scalar2(vv(1),Dtobr2(1,i))
8341 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8342       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8343       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8344      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8345      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8346      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8347      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8348      & +scalar2(vv(1),Dtobr2der(1,i)))
8349       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8350       vv1(1)=pizda1(1,1)-pizda1(2,2)
8351       vv1(2)=pizda1(1,2)+pizda1(2,1)
8352       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8353       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8354       if (l.eq.j+1) then
8355         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8356      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8357      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8358      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8359      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8360       else
8361         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8362      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8363      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8364      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8365      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8366       endif
8367       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8368       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8369       vv1(1)=pizda1(1,1)-pizda1(2,2)
8370       vv1(2)=pizda1(1,2)+pizda1(2,1)
8371       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8372      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8373      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8374      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8375       do iii=1,2
8376         if (swap) then
8377           ind=3-iii
8378         else
8379           ind=iii
8380         endif
8381         do kkk=1,5
8382           do lll=1,3
8383             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8384             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8385             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8386             call transpose2(EUgC(1,1,k),auxmat(1,1))
8387             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8388      &        pizda1(1,1))
8389             vv1(1)=pizda1(1,1)-pizda1(2,2)
8390             vv1(2)=pizda1(1,2)+pizda1(2,1)
8391             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8392             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8393      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8394             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8395      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8396             s5=scalar2(vv(1),Dtobr2(1,i))
8397             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8398           enddo
8399         enddo
8400       enddo
8401       return
8402       end
8403 c----------------------------------------------------------------------------
8404       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8405       implicit real*8 (a-h,o-z)
8406       include 'DIMENSIONS'
8407       include 'COMMON.IOUNITS'
8408       include 'COMMON.CHAIN'
8409       include 'COMMON.DERIV'
8410       include 'COMMON.INTERACT'
8411       include 'COMMON.CONTACTS'
8412       include 'COMMON.TORSION'
8413       include 'COMMON.VAR'
8414       include 'COMMON.GEO'
8415       logical swap
8416       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8417      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8418       logical lprn
8419       common /kutas/ lprn
8420 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8421 C                                                                              C
8422 C      Parallel       Antiparallel                                             C
8423 C                                                                              C
8424 C          o             o                                                     C
8425 C     \   /l\           /j\   /                                                C
8426 C      \ /   \         /   \ /                                                 C
8427 C       o| o |         | o |o                                                  C
8428 C     \ j|/k\|      \  |/k\|l                                                  C
8429 C      \ /   \       \ /   \                                                   C
8430 C       o             o                                                        C
8431 C       i             i                                                        C
8432 C                                                                              C
8433 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8434 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8435 C AL 7/4/01 s1 would occur in the sixth-order moment,
8436 C           but not in a cluster cumulant
8437 #ifdef MOMENT
8438       s1=dip(1,jj,i)*dip(1,kk,k)
8439 #endif
8440       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8441       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8442       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8443       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8444       call transpose2(EUg(1,1,k),auxmat(1,1))
8445       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8446       vv(1)=pizda(1,1)-pizda(2,2)
8447       vv(2)=pizda(1,2)+pizda(2,1)
8448       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8449 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8450 #ifdef MOMENT
8451       eello6_graph2=-(s1+s2+s3+s4)
8452 #else
8453       eello6_graph2=-(s2+s3+s4)
8454 #endif
8455 c      eello6_graph2=-s3
8456 C Derivatives in gamma(i-1)
8457       if (i.gt.1) then
8458 #ifdef MOMENT
8459         s1=dipderg(1,jj,i)*dip(1,kk,k)
8460 #endif
8461         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8462         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8463         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8464         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8465 #ifdef MOMENT
8466         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8467 #else
8468         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8469 #endif
8470 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8471       endif
8472 C Derivatives in gamma(k-1)
8473 #ifdef MOMENT
8474       s1=dip(1,jj,i)*dipderg(1,kk,k)
8475 #endif
8476       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8477       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8478       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8479       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8480       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8481       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8482       vv(1)=pizda(1,1)-pizda(2,2)
8483       vv(2)=pizda(1,2)+pizda(2,1)
8484       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8485 #ifdef MOMENT
8486       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8487 #else
8488       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8489 #endif
8490 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8491 C Derivatives in gamma(j-1) or gamma(l-1)
8492       if (j.gt.1) then
8493 #ifdef MOMENT
8494         s1=dipderg(3,jj,i)*dip(1,kk,k)
8495 #endif
8496         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8497         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8498         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8499         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8500         vv(1)=pizda(1,1)-pizda(2,2)
8501         vv(2)=pizda(1,2)+pizda(2,1)
8502         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8503 #ifdef MOMENT
8504         if (swap) then
8505           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8506         else
8507           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8508         endif
8509 #endif
8510         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8511 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8512       endif
8513 C Derivatives in gamma(l-1) or gamma(j-1)
8514       if (l.gt.1) then
8515 #ifdef MOMENT
8516         s1=dip(1,jj,i)*dipderg(3,kk,k)
8517 #endif
8518         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8519         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8520         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8521         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8522         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8523         vv(1)=pizda(1,1)-pizda(2,2)
8524         vv(2)=pizda(1,2)+pizda(2,1)
8525         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8526 #ifdef MOMENT
8527         if (swap) then
8528           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8529         else
8530           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8531         endif
8532 #endif
8533         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8534 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8535       endif
8536 C Cartesian derivatives.
8537       if (lprn) then
8538         write (2,*) 'In eello6_graph2'
8539         do iii=1,2
8540           write (2,*) 'iii=',iii
8541           do kkk=1,5
8542             write (2,*) 'kkk=',kkk
8543             do jjj=1,2
8544               write (2,'(3(2f10.5),5x)')
8545      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8546             enddo
8547           enddo
8548         enddo
8549       endif
8550       do iii=1,2
8551         do kkk=1,5
8552           do lll=1,3
8553 #ifdef MOMENT
8554             if (iii.eq.1) then
8555               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8556             else
8557               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8558             endif
8559 #endif
8560             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8561      &        auxvec(1))
8562             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8563             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8564      &        auxvec(1))
8565             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8566             call transpose2(EUg(1,1,k),auxmat(1,1))
8567             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8568      &        pizda(1,1))
8569             vv(1)=pizda(1,1)-pizda(2,2)
8570             vv(2)=pizda(1,2)+pizda(2,1)
8571             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8572 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8573 #ifdef MOMENT
8574             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8575 #else
8576             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8577 #endif
8578             if (swap) then
8579               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8580             else
8581               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8582             endif
8583           enddo
8584         enddo
8585       enddo
8586       return
8587       end
8588 c----------------------------------------------------------------------------
8589       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8590       implicit real*8 (a-h,o-z)
8591       include 'DIMENSIONS'
8592       include 'COMMON.IOUNITS'
8593       include 'COMMON.CHAIN'
8594       include 'COMMON.DERIV'
8595       include 'COMMON.INTERACT'
8596       include 'COMMON.CONTACTS'
8597       include 'COMMON.TORSION'
8598       include 'COMMON.VAR'
8599       include 'COMMON.GEO'
8600       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8601       logical swap
8602 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8603 C                                                                              C
8604 C      Parallel       Antiparallel                                             C
8605 C                                                                              C
8606 C          o             o                                                     C
8607 C         /l\   /   \   /j\                                                    C
8608 C        /   \ /     \ /   \                                                   C
8609 C       /| o |o       o| o |\                                                  C
8610 C       j|/k\|  /      |/k\|l /                                                C
8611 C        /   \ /       /   \ /                                                 C
8612 C       /     o       /     o                                                  C
8613 C       i             i                                                        C
8614 C                                                                              C
8615 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8616 C
8617 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8618 C           energy moment and not to the cluster cumulant.
8619       iti=itortyp(itype(i))
8620       if (j.lt.nres-1) then
8621         itj1=itortyp(itype(j+1))
8622       else
8623         itj1=ntortyp+1
8624       endif
8625       itk=itortyp(itype(k))
8626       itk1=itortyp(itype(k+1))
8627       if (l.lt.nres-1) then
8628         itl1=itortyp(itype(l+1))
8629       else
8630         itl1=ntortyp+1
8631       endif
8632 #ifdef MOMENT
8633       s1=dip(4,jj,i)*dip(4,kk,k)
8634 #endif
8635       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8636       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8637       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8638       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8639       call transpose2(EE(1,1,itk),auxmat(1,1))
8640       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8641       vv(1)=pizda(1,1)+pizda(2,2)
8642       vv(2)=pizda(2,1)-pizda(1,2)
8643       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8644 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8645 cd     & "sum",-(s2+s3+s4)
8646 #ifdef MOMENT
8647       eello6_graph3=-(s1+s2+s3+s4)
8648 #else
8649       eello6_graph3=-(s2+s3+s4)
8650 #endif
8651 c      eello6_graph3=-s4
8652 C Derivatives in gamma(k-1)
8653       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8654       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8655       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8656       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8657 C Derivatives in gamma(l-1)
8658       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8659       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8660       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8661       vv(1)=pizda(1,1)+pizda(2,2)
8662       vv(2)=pizda(2,1)-pizda(1,2)
8663       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8664       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8665 C Cartesian derivatives.
8666       do iii=1,2
8667         do kkk=1,5
8668           do lll=1,3
8669 #ifdef MOMENT
8670             if (iii.eq.1) then
8671               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8672             else
8673               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8674             endif
8675 #endif
8676             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8677      &        auxvec(1))
8678             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8679             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8680      &        auxvec(1))
8681             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8682             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8683      &        pizda(1,1))
8684             vv(1)=pizda(1,1)+pizda(2,2)
8685             vv(2)=pizda(2,1)-pizda(1,2)
8686             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8687 #ifdef MOMENT
8688             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8689 #else
8690             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8691 #endif
8692             if (swap) then
8693               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8694             else
8695               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8696             endif
8697 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8698           enddo
8699         enddo
8700       enddo
8701       return
8702       end
8703 c----------------------------------------------------------------------------
8704       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8705       implicit real*8 (a-h,o-z)
8706       include 'DIMENSIONS'
8707       include 'COMMON.IOUNITS'
8708       include 'COMMON.CHAIN'
8709       include 'COMMON.DERIV'
8710       include 'COMMON.INTERACT'
8711       include 'COMMON.CONTACTS'
8712       include 'COMMON.TORSION'
8713       include 'COMMON.VAR'
8714       include 'COMMON.GEO'
8715       include 'COMMON.FFIELD'
8716       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8717      & auxvec1(2),auxmat1(2,2)
8718       logical swap
8719 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8720 C                                                                              C
8721 C      Parallel       Antiparallel                                             C
8722 C                                                                              C
8723 C          o             o                                                     C
8724 C         /l\   /   \   /j\                                                    C
8725 C        /   \ /     \ /   \                                                   C
8726 C       /| o |o       o| o |\                                                  C
8727 C     \ j|/k\|      \  |/k\|l                                                  C
8728 C      \ /   \       \ /   \                                                   C
8729 C       o     \       o     \                                                  C
8730 C       i             i                                                        C
8731 C                                                                              C
8732 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8733 C
8734 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8735 C           energy moment and not to the cluster cumulant.
8736 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8737       iti=itortyp(itype(i))
8738       itj=itortyp(itype(j))
8739       if (j.lt.nres-1) then
8740         itj1=itortyp(itype(j+1))
8741       else
8742         itj1=ntortyp+1
8743       endif
8744       itk=itortyp(itype(k))
8745       if (k.lt.nres-1) then
8746         itk1=itortyp(itype(k+1))
8747       else
8748         itk1=ntortyp+1
8749       endif
8750       itl=itortyp(itype(l))
8751       if (l.lt.nres-1) then
8752         itl1=itortyp(itype(l+1))
8753       else
8754         itl1=ntortyp+1
8755       endif
8756 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8757 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8758 cd     & ' itl',itl,' itl1',itl1
8759 #ifdef MOMENT
8760       if (imat.eq.1) then
8761         s1=dip(3,jj,i)*dip(3,kk,k)
8762       else
8763         s1=dip(2,jj,j)*dip(2,kk,l)
8764       endif
8765 #endif
8766       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8767       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8768       if (j.eq.l+1) then
8769         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8770         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8771       else
8772         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8773         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8774       endif
8775       call transpose2(EUg(1,1,k),auxmat(1,1))
8776       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8777       vv(1)=pizda(1,1)-pizda(2,2)
8778       vv(2)=pizda(2,1)+pizda(1,2)
8779       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8780 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8781 #ifdef MOMENT
8782       eello6_graph4=-(s1+s2+s3+s4)
8783 #else
8784       eello6_graph4=-(s2+s3+s4)
8785 #endif
8786 C Derivatives in gamma(i-1)
8787       if (i.gt.1) then
8788 #ifdef MOMENT
8789         if (imat.eq.1) then
8790           s1=dipderg(2,jj,i)*dip(3,kk,k)
8791         else
8792           s1=dipderg(4,jj,j)*dip(2,kk,l)
8793         endif
8794 #endif
8795         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8796         if (j.eq.l+1) then
8797           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8798           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8799         else
8800           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8801           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8802         endif
8803         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8804         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8805 cd          write (2,*) 'turn6 derivatives'
8806 #ifdef MOMENT
8807           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8808 #else
8809           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8810 #endif
8811         else
8812 #ifdef MOMENT
8813           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8814 #else
8815           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8816 #endif
8817         endif
8818       endif
8819 C Derivatives in gamma(k-1)
8820 #ifdef MOMENT
8821       if (imat.eq.1) then
8822         s1=dip(3,jj,i)*dipderg(2,kk,k)
8823       else
8824         s1=dip(2,jj,j)*dipderg(4,kk,l)
8825       endif
8826 #endif
8827       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8828       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8829       if (j.eq.l+1) then
8830         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8831         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8832       else
8833         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8834         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8835       endif
8836       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8837       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8838       vv(1)=pizda(1,1)-pizda(2,2)
8839       vv(2)=pizda(2,1)+pizda(1,2)
8840       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8841       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8842 #ifdef MOMENT
8843         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8844 #else
8845         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8846 #endif
8847       else
8848 #ifdef MOMENT
8849         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8850 #else
8851         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8852 #endif
8853       endif
8854 C Derivatives in gamma(j-1) or gamma(l-1)
8855       if (l.eq.j+1 .and. l.gt.1) then
8856         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8857         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8858         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8859         vv(1)=pizda(1,1)-pizda(2,2)
8860         vv(2)=pizda(2,1)+pizda(1,2)
8861         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8862         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8863       else if (j.gt.1) then
8864         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8865         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8866         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8867         vv(1)=pizda(1,1)-pizda(2,2)
8868         vv(2)=pizda(2,1)+pizda(1,2)
8869         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8870         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8871           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8872         else
8873           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8874         endif
8875       endif
8876 C Cartesian derivatives.
8877       do iii=1,2
8878         do kkk=1,5
8879           do lll=1,3
8880 #ifdef MOMENT
8881             if (iii.eq.1) then
8882               if (imat.eq.1) then
8883                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8884               else
8885                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8886               endif
8887             else
8888               if (imat.eq.1) then
8889                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8890               else
8891                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8892               endif
8893             endif
8894 #endif
8895             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8896      &        auxvec(1))
8897             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8898             if (j.eq.l+1) then
8899               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8900      &          b1(1,itj1),auxvec(1))
8901               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8902             else
8903               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8904      &          b1(1,itl1),auxvec(1))
8905               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8906             endif
8907             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8908      &        pizda(1,1))
8909             vv(1)=pizda(1,1)-pizda(2,2)
8910             vv(2)=pizda(2,1)+pizda(1,2)
8911             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8912             if (swap) then
8913               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8914 #ifdef MOMENT
8915                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8916      &             -(s1+s2+s4)
8917 #else
8918                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8919      &             -(s2+s4)
8920 #endif
8921                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8922               else
8923 #ifdef MOMENT
8924                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8925 #else
8926                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8927 #endif
8928                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8929               endif
8930             else
8931 #ifdef MOMENT
8932               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8933 #else
8934               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8935 #endif
8936               if (l.eq.j+1) then
8937                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8938               else
8939                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8940               endif
8941             endif
8942           enddo
8943         enddo
8944       enddo
8945       return
8946       end
8947 c----------------------------------------------------------------------------
8948       double precision function eello_turn6(i,jj,kk)
8949       implicit real*8 (a-h,o-z)
8950       include 'DIMENSIONS'
8951       include 'COMMON.IOUNITS'
8952       include 'COMMON.CHAIN'
8953       include 'COMMON.DERIV'
8954       include 'COMMON.INTERACT'
8955       include 'COMMON.CONTACTS'
8956       include 'COMMON.TORSION'
8957       include 'COMMON.VAR'
8958       include 'COMMON.GEO'
8959       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8960      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8961      &  ggg1(3),ggg2(3)
8962       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8963      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8964 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8965 C           the respective energy moment and not to the cluster cumulant.
8966       s1=0.0d0
8967       s8=0.0d0
8968       s13=0.0d0
8969 c
8970       eello_turn6=0.0d0
8971       j=i+4
8972       k=i+1
8973       l=i+3
8974       iti=itortyp(itype(i))
8975       itk=itortyp(itype(k))
8976       itk1=itortyp(itype(k+1))
8977       itl=itortyp(itype(l))
8978       itj=itortyp(itype(j))
8979 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8980 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8981 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8982 cd        eello6=0.0d0
8983 cd        return
8984 cd      endif
8985 cd      write (iout,*)
8986 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8987 cd     &   ' and',k,l
8988 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8989       do iii=1,2
8990         do kkk=1,5
8991           do lll=1,3
8992             derx_turn(lll,kkk,iii)=0.0d0
8993           enddo
8994         enddo
8995       enddo
8996 cd      eij=1.0d0
8997 cd      ekl=1.0d0
8998 cd      ekont=1.0d0
8999       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9000 cd      eello6_5=0.0d0
9001 cd      write (2,*) 'eello6_5',eello6_5
9002 #ifdef MOMENT
9003       call transpose2(AEA(1,1,1),auxmat(1,1))
9004       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9005       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9006       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9007 #endif
9008       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9009       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9010       s2 = scalar2(b1(1,itk),vtemp1(1))
9011 #ifdef MOMENT
9012       call transpose2(AEA(1,1,2),atemp(1,1))
9013       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9014       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9015       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9016 #endif
9017       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9018       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9019       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9020 #ifdef MOMENT
9021       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9022       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9023       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9024       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9025       ss13 = scalar2(b1(1,itk),vtemp4(1))
9026       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9027 #endif
9028 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9029 c      s1=0.0d0
9030 c      s2=0.0d0
9031 c      s8=0.0d0
9032 c      s12=0.0d0
9033 c      s13=0.0d0
9034       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9035 C Derivatives in gamma(i+2)
9036       s1d =0.0d0
9037       s8d =0.0d0
9038 #ifdef MOMENT
9039       call transpose2(AEA(1,1,1),auxmatd(1,1))
9040       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9041       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9042       call transpose2(AEAderg(1,1,2),atempd(1,1))
9043       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9044       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9045 #endif
9046       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9047       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9048       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9049 c      s1d=0.0d0
9050 c      s2d=0.0d0
9051 c      s8d=0.0d0
9052 c      s12d=0.0d0
9053 c      s13d=0.0d0
9054       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9055 C Derivatives in gamma(i+3)
9056 #ifdef MOMENT
9057       call transpose2(AEA(1,1,1),auxmatd(1,1))
9058       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9059       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9060       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9061 #endif
9062       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9063       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9064       s2d = scalar2(b1(1,itk),vtemp1d(1))
9065 #ifdef MOMENT
9066       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9067       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9068 #endif
9069       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9070 #ifdef MOMENT
9071       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9072       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9073       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9074 #endif
9075 c      s1d=0.0d0
9076 c      s2d=0.0d0
9077 c      s8d=0.0d0
9078 c      s12d=0.0d0
9079 c      s13d=0.0d0
9080 #ifdef MOMENT
9081       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9082      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9083 #else
9084       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9085      &               -0.5d0*ekont*(s2d+s12d)
9086 #endif
9087 C Derivatives in gamma(i+4)
9088       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9089       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9090       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9091 #ifdef MOMENT
9092       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9093       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9094       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9095 #endif
9096 c      s1d=0.0d0
9097 c      s2d=0.0d0
9098 c      s8d=0.0d0
9099 C      s12d=0.0d0
9100 c      s13d=0.0d0
9101 #ifdef MOMENT
9102       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9103 #else
9104       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9105 #endif
9106 C Derivatives in gamma(i+5)
9107 #ifdef MOMENT
9108       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9109       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9110       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9111 #endif
9112       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9113       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9114       s2d = scalar2(b1(1,itk),vtemp1d(1))
9115 #ifdef MOMENT
9116       call transpose2(AEA(1,1,2),atempd(1,1))
9117       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9118       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9119 #endif
9120       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9121       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9122 #ifdef MOMENT
9123       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9124       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9125       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9126 #endif
9127 c      s1d=0.0d0
9128 c      s2d=0.0d0
9129 c      s8d=0.0d0
9130 c      s12d=0.0d0
9131 c      s13d=0.0d0
9132 #ifdef MOMENT
9133       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9134      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9135 #else
9136       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9137      &               -0.5d0*ekont*(s2d+s12d)
9138 #endif
9139 C Cartesian derivatives
9140       do iii=1,2
9141         do kkk=1,5
9142           do lll=1,3
9143 #ifdef MOMENT
9144             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9145             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9146             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9147 #endif
9148             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9149             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9150      &          vtemp1d(1))
9151             s2d = scalar2(b1(1,itk),vtemp1d(1))
9152 #ifdef MOMENT
9153             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9154             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9155             s8d = -(atempd(1,1)+atempd(2,2))*
9156      &           scalar2(cc(1,1,itl),vtemp2(1))
9157 #endif
9158             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9159      &           auxmatd(1,1))
9160             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9161             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9162 c      s1d=0.0d0
9163 c      s2d=0.0d0
9164 c      s8d=0.0d0
9165 c      s12d=0.0d0
9166 c      s13d=0.0d0
9167 #ifdef MOMENT
9168             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9169      &        - 0.5d0*(s1d+s2d)
9170 #else
9171             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9172      &        - 0.5d0*s2d
9173 #endif
9174 #ifdef MOMENT
9175             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9176      &        - 0.5d0*(s8d+s12d)
9177 #else
9178             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9179      &        - 0.5d0*s12d
9180 #endif
9181           enddo
9182         enddo
9183       enddo
9184 #ifdef MOMENT
9185       do kkk=1,5
9186         do lll=1,3
9187           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9188      &      achuj_tempd(1,1))
9189           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9190           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9191           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9192           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9193           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9194      &      vtemp4d(1))
9195           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9196           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9197           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9198         enddo
9199       enddo
9200 #endif
9201 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9202 cd     &  16*eel_turn6_num
9203 cd      goto 1112
9204       if (j.lt.nres-1) then
9205         j1=j+1
9206         j2=j-1
9207       else
9208         j1=j-1
9209         j2=j-2
9210       endif
9211       if (l.lt.nres-1) then
9212         l1=l+1
9213         l2=l-1
9214       else
9215         l1=l-1
9216         l2=l-2
9217       endif
9218       do ll=1,3
9219 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9220 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9221 cgrad        ghalf=0.5d0*ggg1(ll)
9222 cd        ghalf=0.0d0
9223         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9224         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9225         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9226      &    +ekont*derx_turn(ll,2,1)
9227         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9228         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9229      &    +ekont*derx_turn(ll,4,1)
9230         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9231         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9232         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9233 cgrad        ghalf=0.5d0*ggg2(ll)
9234 cd        ghalf=0.0d0
9235         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9236      &    +ekont*derx_turn(ll,2,2)
9237         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9238         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9239      &    +ekont*derx_turn(ll,4,2)
9240         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9241         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9242         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9243       enddo
9244 cd      goto 1112
9245 cgrad      do m=i+1,j-1
9246 cgrad        do ll=1,3
9247 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9248 cgrad        enddo
9249 cgrad      enddo
9250 cgrad      do m=k+1,l-1
9251 cgrad        do ll=1,3
9252 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9253 cgrad        enddo
9254 cgrad      enddo
9255 cgrad1112  continue
9256 cgrad      do m=i+2,j2
9257 cgrad        do ll=1,3
9258 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9259 cgrad        enddo
9260 cgrad      enddo
9261 cgrad      do m=k+2,l2
9262 cgrad        do ll=1,3
9263 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9264 cgrad        enddo
9265 cgrad      enddo
9266 cd      do iii=1,nres-3
9267 cd        write (2,*) iii,g_corr6_loc(iii)
9268 cd      enddo
9269       eello_turn6=ekont*eel_turn6
9270 cd      write (2,*) 'ekont',ekont
9271 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9272       return
9273       end
9274
9275 C-----------------------------------------------------------------------------
9276       double precision function scalar(u,v)
9277 !DIR$ INLINEALWAYS scalar
9278 #ifndef OSF
9279 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9280 #endif
9281       implicit none
9282       double precision u(3),v(3)
9283 cd      double precision sc
9284 cd      integer i
9285 cd      sc=0.0d0
9286 cd      do i=1,3
9287 cd        sc=sc+u(i)*v(i)
9288 cd      enddo
9289 cd      scalar=sc
9290
9291       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9292       return
9293       end
9294 crc-------------------------------------------------
9295       SUBROUTINE MATVEC2(A1,V1,V2)
9296 !DIR$ INLINEALWAYS MATVEC2
9297 #ifndef OSF
9298 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9299 #endif
9300       implicit real*8 (a-h,o-z)
9301       include 'DIMENSIONS'
9302       DIMENSION A1(2,2),V1(2),V2(2)
9303 c      DO 1 I=1,2
9304 c        VI=0.0
9305 c        DO 3 K=1,2
9306 c    3     VI=VI+A1(I,K)*V1(K)
9307 c        Vaux(I)=VI
9308 c    1 CONTINUE
9309
9310       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9311       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9312
9313       v2(1)=vaux1
9314       v2(2)=vaux2
9315       END
9316 C---------------------------------------
9317       SUBROUTINE MATMAT2(A1,A2,A3)
9318 #ifndef OSF
9319 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9320 #endif
9321       implicit real*8 (a-h,o-z)
9322       include 'DIMENSIONS'
9323       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9324 c      DIMENSION AI3(2,2)
9325 c        DO  J=1,2
9326 c          A3IJ=0.0
9327 c          DO K=1,2
9328 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9329 c          enddo
9330 c          A3(I,J)=A3IJ
9331 c       enddo
9332 c      enddo
9333
9334       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9335       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9336       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9337       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9338
9339       A3(1,1)=AI3_11
9340       A3(2,1)=AI3_21
9341       A3(1,2)=AI3_12
9342       A3(2,2)=AI3_22
9343       END
9344
9345 c-------------------------------------------------------------------------
9346       double precision function scalar2(u,v)
9347 !DIR$ INLINEALWAYS scalar2
9348       implicit none
9349       double precision u(2),v(2)
9350       double precision sc
9351       integer i
9352       scalar2=u(1)*v(1)+u(2)*v(2)
9353       return
9354       end
9355
9356 C-----------------------------------------------------------------------------
9357
9358       subroutine transpose2(a,at)
9359 !DIR$ INLINEALWAYS transpose2
9360 #ifndef OSF
9361 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9362 #endif
9363       implicit none
9364       double precision a(2,2),at(2,2)
9365       at(1,1)=a(1,1)
9366       at(1,2)=a(2,1)
9367       at(2,1)=a(1,2)
9368       at(2,2)=a(2,2)
9369       return
9370       end
9371 c--------------------------------------------------------------------------
9372       subroutine transpose(n,a,at)
9373       implicit none
9374       integer n,i,j
9375       double precision a(n,n),at(n,n)
9376       do i=1,n
9377         do j=1,n
9378           at(j,i)=a(i,j)
9379         enddo
9380       enddo
9381       return
9382       end
9383 C---------------------------------------------------------------------------
9384       subroutine prodmat3(a1,a2,kk,transp,prod)
9385 !DIR$ INLINEALWAYS prodmat3
9386 #ifndef OSF
9387 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9388 #endif
9389       implicit none
9390       integer i,j
9391       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9392       logical transp
9393 crc      double precision auxmat(2,2),prod_(2,2)
9394
9395       if (transp) then
9396 crc        call transpose2(kk(1,1),auxmat(1,1))
9397 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9398 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9399
9400            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9401      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9402            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9403      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9404            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9405      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9406            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9407      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9408
9409       else
9410 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9411 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9412
9413            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9414      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9415            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9416      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9417            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9418      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9419            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9420      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9421
9422       endif
9423 c      call transpose2(a2(1,1),a2t(1,1))
9424
9425 crc      print *,transp
9426 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9427 crc      print *,((prod(i,j),i=1,2),j=1,2)
9428
9429       return
9430       end
9431