source/unres/src_MIN/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD_'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57           weights_(22)=wsct
  58 C FG Master broadcasts the WEIGHTS_ array
  59           call MPI_Bcast(weights_(1),n_ene,
  60      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  61         else
  62 C FG slaves receive the WEIGHTS array
  63           call MPI_Bcast(weights(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65           wsc=weights(1)
  66           wscp=weights(2)
  67           welec=weights(3)
  68           wcorr=weights(4)
  69           wcorr5=weights(5)
  70           wcorr6=weights(6)
  71           wel_loc=weights(7)
  72           wturn3=weights(8)
  73           wturn4=weights(9)
  74           wturn6=weights(10)
  75           wang=weights(11)
  76           wscloc=weights(12)
  77           wtor=weights(13)
  78           wtor_d=weights(14)
  79           wstrain=weights(15)
  80           wvdwpp=weights(16)
  81           wbond=weights(17)
  82           scal14=weights(18)
  83           wsccor=weights(21)
  84           wsct=weights(22)
  85         endif
  86         time_Bcast=time_Bcast+MPI_Wtime()-time00
  87         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  88 c        call chainbuild_cart
  89       endif
  90 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  91 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  92 #else
  93 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  94 c        call int_from_cart1(.false.)
  95 c      endif
  96 #endif
  97 #ifdef TIMING
  98       time00=MPI_Wtime()
  99 #endif
 100 C
 101 C Compute the side-chain and electrostatic interaction energy
 102 C
 103       goto (101,102,103,104,105,106) ipot
 104 C Lennard-Jones potential.
 105   101 call elj(evdw,evdw_p,evdw_m)
 106 cd    print '(a)','Exit ELJ'
 107       goto 107
 108 C Lennard-Jones-Kihara potential (shifted).
 109   102 call eljk(evdw,evdw_p,evdw_m)
 110       goto 107
 111 C Berne-Pechukas potential (dilated LJ, angular dependence).
 112   103 call ebp(evdw,evdw_p,evdw_m)
 113       goto 107
 114 C Gay-Berne potential (shifted LJ, angular dependence).
 115   104 call egb(evdw,evdw_p,evdw_m)
 116       goto 107
 117 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 118   105 call egbv(evdw,evdw_p,evdw_m)
 119       goto 107
 120 C Soft-sphere potential
 121   106 call e_softsphere(evdw)
 122 C
 123 C Calculate electrostatic (H-bonding) energy of the main chain.
 124 C
 125   107 continue
 126 c      print *,"Processor",myrank," computed USCSC"
 127 #ifdef TIMING
 128       time01=MPI_Wtime()
 129 #endif
 130       call vec_and_deriv
 131 #ifdef TIMING
 132       time_vec=time_vec+MPI_Wtime()-time01
 133 #endif
 134 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 135       if (ipot.lt.6) then
 136 #ifdef SPLITELE
 137          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 138      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 139      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 140      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 141 #else
 142          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 143      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 144      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 145      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 146 #endif
 147             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 148          else
 149             ees=0.0d0
 150             evdw1=0.0d0
 151             eel_loc=0.0d0
 152             eello_turn3=0.0d0
 153             eello_turn4=0.0d0
 154          endif
 155       else
 156 c        write (iout,*) "Soft-spheer ELEC potential"
 157         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 158      &   eello_turn4)
 159       endif
 160 c      print *,"Processor",myrank," computed UELEC"
 161 C
 162 C Calculate excluded-volume interaction energy between peptide groups
 163 C and side chains.
 164 C
 165       if (ipot.lt.6) then
 166        if(wscp.gt.0d0) then
 167         call escp(evdw2,evdw2_14)
 168        else
 169         evdw2=0
 170         evdw2_14=0
 171        endif
 172       else
 173 c        write (iout,*) "Soft-sphere SCP potential"
 174         call escp_soft_sphere(evdw2,evdw2_14)
 175       endif
 176 c
 177 c Calculate the bond-stretching energy
 178 c
 179       call ebond(estr)
 180 C
 181 C Calculate the disulfide-bridge and other energy and the contributions
 182 C from other distance constraints.
 183 cd    print *,'Calling EHPB'
 184       call edis(ehpb)
 185 cd    print *,'EHPB exitted succesfully.'
 186 C
 187 C Calculate the virtual-bond-angle energy.
 188 C
 189       if (wang.gt.0d0) then
 190         call ebend(ebe)
 191       else
 192         ebe=0
 193       endif
 194 c      print *,"Processor",myrank," computed UB"
 195 C
 196 C Calculate the SC local energy.
 197 C
 198       call esc(escloc)
 199 c      print *,"Processor",myrank," computed USC"
 200 C
 201 C Calculate the virtual-bond torsional energy.
 202 C
 203 cd    print *,'nterm=',nterm
 204       if (wtor.gt.0) then
 205        call etor(etors,edihcnstr)
 206       else
 207        etors=0
 208        edihcnstr=0
 209       endif
 210 c      print *,"Processor",myrank," computed Utor"
 211 C
 212 C 6/23/01 Calculate double-torsional energy
 213 C
 214       if (wtor_d.gt.0) then
 215        call etor_d(etors_d)
 216       else
 217        etors_d=0
 218       endif
 219 c      print *,"Processor",myrank," computed Utord"
 220 C
 221 C 21/5/07 Calculate local sicdechain correlation energy
 222 C
 223       if (wsccor.gt.0.0d0) then
 224         call eback_sc_corr(esccor)
 225       else
 226         esccor=0.0d0
 227       endif
 228 c      print *,"Processor",myrank," computed Usccorr"
 229 C
 230 C 12/1/95 Multi-body terms
 231 C
 232       n_corr=0
 233       n_corr1=0
 234       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 235      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 236          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 237 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 238 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 239       else
 240          ecorr=0.0d0
 241          ecorr5=0.0d0
 242          ecorr6=0.0d0
 243          eturn6=0.0d0
 244       endif
 245       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 246          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 247 cd         write (iout,*) "multibody_hb ecorr",ecorr
 248       endif
 249 c      print *,"Processor",myrank," computed Ucorr"
 250 C
 251 C If performing constraint dynamics, call the constraint energy
 252 C  after the equilibration time
 253       if(usampl.and.totT.gt.eq_time) then
 254 c         call EconstrQ
 255          call Econstr_back
 256       else
 257          Uconst=0.0d0
 258          Uconst_back=0.0d0
 259       endif
 260 #ifdef TIMING
 261       time_enecalc=time_enecalc+MPI_Wtime()-time00
 262 #endif
 263 c      print *,"Processor",myrank," computed Uconstr"
 264 #ifdef TIMING
 265       time00=MPI_Wtime()
 266 #endif
 267 c
 268 C Sum the energies
 269 C
 270       energia(1)=evdw
 271 #ifdef SCP14
 272       energia(2)=evdw2-evdw2_14
 273       energia(18)=evdw2_14
 274 #else
 275       energia(2)=evdw2
 276       energia(18)=0.0d0
 277 #endif
 278 #ifdef SPLITELE
 279       energia(3)=ees
 280       energia(16)=evdw1
 281 #else
 282       energia(3)=ees+evdw1
 283       energia(16)=0.0d0
 284 #endif
 285       energia(4)=ecorr
 286       energia(5)=ecorr5
 287       energia(6)=ecorr6
 288       energia(7)=eel_loc
 289       energia(8)=eello_turn3
 290       energia(9)=eello_turn4
 291       energia(10)=eturn6
 292       energia(11)=ebe
 293       energia(12)=escloc
 294       energia(13)=etors
 295       energia(14)=etors_d
 296       energia(15)=ehpb
 297       energia(19)=edihcnstr
 298       energia(17)=estr
 299       energia(20)=Uconst+Uconst_back
 300       energia(21)=esccor
 301       energia(22)=evdw_p
 302       energia(23)=evdw_m
 303 c      print *," Processor",myrank," calls SUM_ENERGY"
 304       call sum_energy(energia,.true.)
 305 c      print *," Processor",myrank," left SUM_ENERGY"
 306 #ifdef TIMING
 307       time_sumene=time_sumene+MPI_Wtime()-time00
 308 #endif
 309       return
 310       end
 311 c-------------------------------------------------------------------------------
 312       subroutine sum_energy(energia,reduce)
 313       implicit real*8 (a-h,o-z)
 314       include 'DIMENSIONS'
 315 #ifndef ISNAN
 316       external proc_proc
 317 #ifdef WINPGI
 318 cMS$ATTRIBUTES C ::  proc_proc
 319 #endif
 320 #endif
 321 #ifdef MPI
 322       include "mpif.h"
 323 #endif
 324       include 'COMMON.SETUP'
 325       include 'COMMON.IOUNITS'
 326       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 327       include 'COMMON.FFIELD'
 328       include 'COMMON.DERIV'
 329       include 'COMMON.INTERACT'
 330       include 'COMMON.SBRIDGE'
 331       include 'COMMON.CHAIN'
 332       include 'COMMON.VAR'
 333       include 'COMMON.CONTROL'
 334       include 'COMMON.TIME1'
 335       logical reduce
 336 #ifdef MPI
 337       if (nfgtasks.gt.1 .and. reduce) then
 338 #ifdef DEBUG
 339         write (iout,*) "energies before REDUCE"
 340         call enerprint(energia)
 341         call flush(iout)
 342 #endif
 343         do i=0,n_ene
 344           enebuff(i)=energia(i)
 345         enddo
 346         time00=MPI_Wtime()
 347         call MPI_Barrier(FG_COMM,IERR)
 348         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 349         time00=MPI_Wtime()
 350         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 351      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 352 #ifdef DEBUG
 353         write (iout,*) "energies after REDUCE"
 354         call enerprint(energia)
 355         call flush(iout)
 356 #endif
 357         time_Reduce=time_Reduce+MPI_Wtime()-time00
 358       endif
 359       if (fg_rank.eq.0) then
 360 #endif
 361 #ifdef TSCSC
 362       evdw=energia(22)+wsct*energia(23)
 363 #else
 364       evdw=energia(1)
 365 #endif
 366 #ifdef SCP14
 367       evdw2=energia(2)+energia(18)
 368       evdw2_14=energia(18)
 369 #else
 370       evdw2=energia(2)
 371 #endif
 372 #ifdef SPLITELE
 373       ees=energia(3)
 374       evdw1=energia(16)
 375 #else
 376       ees=energia(3)
 377       evdw1=0.0d0
 378 #endif
 379       ecorr=energia(4)
 380       ecorr5=energia(5)
 381       ecorr6=energia(6)
 382       eel_loc=energia(7)
 383       eello_turn3=energia(8)
 384       eello_turn4=energia(9)
 385       eturn6=energia(10)
 386       ebe=energia(11)
 387       escloc=energia(12)
 388       etors=energia(13)
 389       etors_d=energia(14)
 390       ehpb=energia(15)
 391       edihcnstr=energia(19)
 392       estr=energia(17)
 393       Uconst=energia(20)
 394       esccor=energia(21)
 395 #ifdef SPLITELE
 396       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 397      & +wang*ebe+wtor*etors+wscloc*escloc
 398      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 399      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 400      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 401      & +wbond*estr+Uconst+wsccor*esccor
 402 #else
 403       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 404      & +wang*ebe+wtor*etors+wscloc*escloc
 405      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 406      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 407      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 408      & +wbond*estr+Uconst+wsccor*esccor
 409 #endif
 410       energia(0)=etot
 411 c detecting NaNQ
 412 #ifdef ISNAN
 413 #ifdef AIX
 414       if (isnan(etot).ne.0) energia(0)=1.0d+99
 415 #else
 416       if (isnan(etot)) energia(0)=1.0d+99
 417 #endif
 418 #else
 419       i=0
 420 #ifdef WINPGI
 421       idumm=proc_proc(etot,i)
 422 #else
 423       call proc_proc(etot,i)
 424 #endif
 425       if(i.eq.1)energia(0)=1.0d+99
 426 #endif
 427 #ifdef MPI
 428       endif
 429 #endif
 430       return
 431       end
 432 c-------------------------------------------------------------------------------
 433       subroutine sum_gradient
 434       implicit real*8 (a-h,o-z)
 435       include 'DIMENSIONS'
 436 #ifndef ISNAN
 437       external proc_proc
 438 #ifdef WINPGI
 439 cMS$ATTRIBUTES C ::  proc_proc
 440 #endif
 441 #endif
 442 #ifdef MPI
 443       include 'mpif.h'
 444       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 445      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 446 #else
 447       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 448      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 449 #endif
 450       include 'COMMON.SETUP'
 451       include 'COMMON.IOUNITS'
 452       include 'COMMON.FFIELD'
 453       include 'COMMON.DERIV'
 454       include 'COMMON.INTERACT'
 455       include 'COMMON.SBRIDGE'
 456       include 'COMMON.CHAIN'
 457       include 'COMMON.VAR'
 458       include 'COMMON.CONTROL'
 459       include 'COMMON.TIME1'
 460       include 'COMMON.MAXGRAD'
 461 #ifdef TIMING
 462       time01=MPI_Wtime()
 463 #endif
 464 #ifdef DEBUG
 465       write (iout,*) "sum_gradient gvdwc, gvdwx"
 466       do i=1,nres
 467         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 468      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 469      &   (gvdwcT(j,i),j=1,3)
 470       enddo
 471       call flush(iout)
 472 #endif
 473 #ifdef MPI
 474 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 475         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 476      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 477 #endif
 478 C
 479 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 480 C            in virtual-bond-vector coordinates
 481 C
 482 #ifdef DEBUG
 483 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 484 c      do i=1,nres-1
 485 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 486 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 487 c      enddo
 488 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 489 c      do i=1,nres-1
 490 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 491 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 492 c      enddo
 493       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 494       do i=1,nres
 495         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 496      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 497      &   g_corr5_loc(i)
 498       enddo
 499       call flush(iout)
 500 #endif
 501 #ifdef SPLITELE
 502 #ifdef TSCSC
 503       do i=1,nct
 504         do j=1,3
 505           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 506      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 507      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 508      &                wel_loc*gel_loc_long(j,i)+
 509      &                wcorr*gradcorr_long(j,i)+
 510      &                wcorr5*gradcorr5_long(j,i)+
 511      &                wcorr6*gradcorr6_long(j,i)+
 512      &                wturn6*gcorr6_turn_long(j,i)+
 513      &                wstrain*ghpbc(j,i)
 514         enddo
 515       enddo
 516 #else
 517       do i=1,nct
 518         do j=1,3
 519           gradbufc(j,i)=wsc*gvdwc(j,i)+
 520      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 521      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 522      &                wel_loc*gel_loc_long(j,i)+
 523      &                wcorr*gradcorr_long(j,i)+
 524      &                wcorr5*gradcorr5_long(j,i)+
 525      &                wcorr6*gradcorr6_long(j,i)+
 526      &                wturn6*gcorr6_turn_long(j,i)+
 527      &                wstrain*ghpbc(j,i)
 528         enddo
 529       enddo
 530 #endif
 531 #else
 532       do i=1,nct
 533         do j=1,3
 534           gradbufc(j,i)=wsc*gvdwc(j,i)+
 535      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 536      &                welec*gelc_long(j,i)+
 537      &                wbond*gradb(j,i)+
 538      &                wel_loc*gel_loc_long(j,i)+
 539      &                wcorr*gradcorr_long(j,i)+
 540      &                wcorr5*gradcorr5_long(j,i)+
 541      &                wcorr6*gradcorr6_long(j,i)+
 542      &                wturn6*gcorr6_turn_long(j,i)+
 543      &                wstrain*ghpbc(j,i)
 544         enddo
 545       enddo
 546 #endif
 547 #ifdef MPI
 548       if (nfgtasks.gt.1) then
 549       time00=MPI_Wtime()
 550 #ifdef DEBUG
 551       write (iout,*) "gradbufc before allreduce"
 552       do i=1,nres
 553         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 554       enddo
 555       call flush(iout)
 556 #endif
 557       call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 558      &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 559       time_reduce=time_reduce+MPI_Wtime()-time00
 560 #ifdef DEBUG
 561       write (iout,*) "gradbufc_sum after allreduce"
 562       do i=1,nres
 563         write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 564       enddo
 565       call flush(iout)
 566 #endif
 567 #ifdef TIMING
 568       time_allreduce=time_allreduce+MPI_Wtime()-time00
 569 #endif
 570       do i=nnt,nres
 571         do k=1,3
 572           gradbufc(k,i)=0.0d0
 573         enddo
 574       enddo
 575       do i=igrad_start,igrad_end
 576         do j=jgrad_start(i),jgrad_end(i)
 577           do k=1,3
 578             gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 579           enddo
 580         enddo
 581       enddo
 582       else
 583 #endif
 584 #ifdef DEBUG
 585       write (iout,*) "gradbufc"
 586       do i=1,nres
 587         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 588       enddo
 589       call flush(iout)
 590 #endif
 591       do i=nnt,nres-1
 592         do k=1,3
 593           gradbufc(k,i)=0.0d0
 594         enddo
 595         do j=i+1,nres
 596           do k=1,3
 597             gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 598           enddo
 599         enddo
 600       enddo
 601 #ifdef MPI
 602       endif
 603 #endif
 604       do k=1,3
 605         gradbufc(k,nres)=0.0d0
 606       enddo
 607       do i=1,nct
 608         do j=1,3
 609 #ifdef SPLITELE
 610           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 611      &                wel_loc*gel_loc(j,i)+
 612      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 613      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 614      &                wel_loc*gel_loc_long(j,i)+
 615      &                wcorr*gradcorr_long(j,i)+
 616      &                wcorr5*gradcorr5_long(j,i)+
 617      &                wcorr6*gradcorr6_long(j,i)+
 618      &                wturn6*gcorr6_turn_long(j,i))+
 619      &                wbond*gradb(j,i)+
 620      &                wcorr*gradcorr(j,i)+
 621      &                wturn3*gcorr3_turn(j,i)+
 622      &                wturn4*gcorr4_turn(j,i)+
 623      &                wcorr5*gradcorr5(j,i)+
 624      &                wcorr6*gradcorr6(j,i)+
 625      &                wturn6*gcorr6_turn(j,i)+
 626      &                wsccor*gsccorc(j,i)
 627      &               +wscloc*gscloc(j,i)
 628 #else
 629           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 630      &                wel_loc*gel_loc(j,i)+
 631      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 632      &                welec*gelc_long(j,i)+
 633      &                wel_loc*gel_loc_long(j,i)+
 634      &                wcorr*gcorr_long(j,i)+
 635      &                wcorr5*gradcorr5_long(j,i)+
 636      &                wcorr6*gradcorr6_long(j,i)+
 637      &                wturn6*gcorr6_turn_long(j,i))+
 638      &                wbond*gradb(j,i)+
 639      &                wcorr*gradcorr(j,i)+
 640      &                wturn3*gcorr3_turn(j,i)+
 641      &                wturn4*gcorr4_turn(j,i)+
 642      &                wcorr5*gradcorr5(j,i)+
 643      &                wcorr6*gradcorr6(j,i)+
 644      &                wturn6*gcorr6_turn(j,i)+
 645      &                wsccor*gsccorc(j,i)
 646      &               +wscloc*gscloc(j,i)
 647 #endif
 648 #ifdef TSCSC
 649           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 650      &                  wscp*gradx_scp(j,i)+
 651      &                  wbond*gradbx(j,i)+
 652      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 653      &                  wsccor*gsccorx(j,i)
 654      &                 +wscloc*gsclocx(j,i)
 655 #else
 656           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 657      &                  wbond*gradbx(j,i)+
 658      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 659      &                  wsccor*gsccorx(j,i)
 660      &                 +wscloc*gsclocx(j,i)
 661 #endif
 662         enddo
 663       enddo
 664 #ifdef DEBUG
 665       write (iout,*) "gloc before adding corr"
 666       do i=1,4*nres
 667         write (iout,*) i,gloc(i,icg)
 668       enddo
 669 #endif
 670       do i=1,nres-3
 671         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 672      &   +wcorr5*g_corr5_loc(i)
 673      &   +wcorr6*g_corr6_loc(i)
 674      &   +wturn4*gel_loc_turn4(i)
 675      &   +wturn3*gel_loc_turn3(i)
 676      &   +wturn6*gel_loc_turn6(i)
 677      &   +wel_loc*gel_loc_loc(i)
 678      &   +wsccor*gsccor_loc(i)
 679       enddo
 680 #ifdef DEBUG
 681       write (iout,*) "gloc after adding corr"
 682       do i=1,4*nres
 683         write (iout,*) i,gloc(i,icg)
 684       enddo
 685 #endif
 686 #ifdef MPI
 687       if (nfgtasks.gt.1) then
 688         do j=1,3
 689           do i=1,nres
 690             gradbufc(j,i)=gradc(j,i,icg)
 691             gradbufx(j,i)=gradx(j,i,icg)
 692           enddo
 693         enddo
 694         do i=1,4*nres
 695           glocbuf(i)=gloc(i,icg)
 696         enddo
 697         time00=MPI_Wtime()
 698         call MPI_Barrier(FG_COMM,IERR)
 699         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 700         time00=MPI_Wtime()
 701         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 702      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 703         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 704      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 705         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 706      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 707         time_reduce=time_reduce+MPI_Wtime()-time00
 708 #ifdef DEBUG
 709       write (iout,*) "gloc after reduce"
 710       do i=1,4*nres
 711         write (iout,*) i,gloc(i,icg)
 712       enddo
 713 #endif
 714       endif
 715 #endif
 716       if (gnorm_check) then
 717 c
 718 c Compute the maximum elements of the gradient
 719 c
 720       gvdwc_max=0.0d0
 721       gvdwc_scp_max=0.0d0
 722       gelc_max=0.0d0
 723       gvdwpp_max=0.0d0
 724       gradb_max=0.0d0
 725       ghpbc_max=0.0d0
 726       gradcorr_max=0.0d0
 727       gel_loc_max=0.0d0
 728       gcorr3_turn_max=0.0d0
 729       gcorr4_turn_max=0.0d0
 730       gradcorr5_max=0.0d0
 731       gradcorr6_max=0.0d0
 732       gcorr6_turn_max=0.0d0
 733       gsccorc_max=0.0d0
 734       gscloc_max=0.0d0
 735       gvdwx_max=0.0d0
 736       gradx_scp_max=0.0d0
 737       ghpbx_max=0.0d0
 738       gradxorr_max=0.0d0
 739       gsccorx_max=0.0d0
 740       gsclocx_max=0.0d0
 741       do i=1,nct
 742         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 743         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 744 #ifdef TSCSC
 745         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 746         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 747 #endif
 748         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 749         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 750      &   gvdwc_scp_max=gvdwc_scp_norm
 751         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 752         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 753         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 754         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 755         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 756         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 757         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 758         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 759         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 760         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 761         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 762         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 763         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 764      &    gcorr3_turn(1,i)))
 765         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 766      &    gcorr3_turn_max=gcorr3_turn_norm
 767         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 768      &    gcorr4_turn(1,i)))
 769         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 770      &    gcorr4_turn_max=gcorr4_turn_norm
 771         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 772         if (gradcorr5_norm.gt.gradcorr5_max)
 773      &    gradcorr5_max=gradcorr5_norm
 774         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 775         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 776         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 777      &    gcorr6_turn(1,i)))
 778         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 779      &    gcorr6_turn_max=gcorr6_turn_norm
 780         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 781         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 782         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 783         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 784         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 785         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 786 #ifdef TSCSC
 787         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 788         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 789 #endif
 790         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 791         if (gradx_scp_norm.gt.gradx_scp_max)
 792      &    gradx_scp_max=gradx_scp_norm
 793         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 794         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 795         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 796         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 797         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 798         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 799         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 800         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 801       enddo
 802       if (gradout) then
 803 #ifdef AIX
 804         open(istat,file=statname,position="append")
 805 #else
 806         open(istat,file=statname,access="append")
 807 #endif
 808         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 809      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 810      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 811      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 812      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 813      &     gsccorx_max,gsclocx_max
 814         close(istat)
 815         if (gvdwc_max.gt.1.0d4) then
 816           write (iout,*) "gvdwc gvdwx gradb gradbx"
 817           do i=nnt,nct
 818             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 819      &        gradb(j,i),gradbx(j,i),j=1,3)
 820           enddo
 821           call pdbout(0.0d0,'cipiszcze',iout)
 822           call flush(iout)
 823         endif
 824       endif
 825       endif
 826 #ifdef DEBUG
 827       write (iout,*) "gradc gradx gloc"
 828       do i=1,nres
 829         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 830      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 831       enddo
 832 #endif
 833 #ifdef TIMING
 834       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 835 #endif
 836       return
 837       end
 838 c-------------------------------------------------------------------------------
 839       subroutine rescale_weights(t_bath)
 840       implicit real*8 (a-h,o-z)
 841       include 'DIMENSIONS'
 842       include 'COMMON.IOUNITS'
 843       include 'COMMON.FFIELD'
 844       include 'COMMON.SBRIDGE'
 845       double precision kfac /2.4d0/
 846       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 847 c      facT=temp0/t_bath
 848 c      facT=2*temp0/(t_bath+temp0)
 849       if (rescale_mode.eq.0) then
 850         facT=1.0d0
 851         facT2=1.0d0
 852         facT3=1.0d0
 853         facT4=1.0d0
 854         facT5=1.0d0
 855       else if (rescale_mode.eq.1) then
 856         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 857         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 858         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 859         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 860         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 861       else if (rescale_mode.eq.2) then
 862         x=t_bath/temp0
 863         x2=x*x
 864         x3=x2*x
 865         x4=x3*x
 866         x5=x4*x
 867         facT=licznik/dlog(dexp(x)+dexp(-x))
 868         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 869         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 870         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 871         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 872       else
 873         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 874         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 875 #ifdef MPI
 876        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 877 #endif
 878        stop 555
 879       endif
 880       welec=weights(3)*fact
 881       wcorr=weights(4)*fact3
 882       wcorr5=weights(5)*fact4
 883       wcorr6=weights(6)*fact5
 884       wel_loc=weights(7)*fact2
 885       wturn3=weights(8)*fact2
 886       wturn4=weights(9)*fact3
 887       wturn6=weights(10)*fact5
 888       wtor=weights(13)*fact
 889       wtor_d=weights(14)*fact2
 890       wsccor=weights(21)*fact
 891 #ifdef TSCSC
 892 c      wsct=t_bath/temp0
 893       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 894 #endif
 895       return
 896       end
 897 C------------------------------------------------------------------------
 898       subroutine enerprint(energia)
 899       implicit real*8 (a-h,o-z)
 900       include 'DIMENSIONS'
 901       include 'COMMON.IOUNITS'
 902       include 'COMMON.FFIELD'
 903       include 'COMMON.SBRIDGE'
 904       include 'COMMON.MD_'
 905       double precision energia(0:n_ene)
 906       etot=energia(0)
 907 #ifdef TSCSC
 908       evdw=energia(22)+wsct*energia(23)
 909 #else
 910       evdw=energia(1)
 911 #endif
 912       evdw2=energia(2)
 913 #ifdef SCP14
 914       evdw2=energia(2)+energia(18)
 915 #else
 916       evdw2=energia(2)
 917 #endif
 918       ees=energia(3)
 919 #ifdef SPLITELE
 920       evdw1=energia(16)
 921 #endif
 922       ecorr=energia(4)
 923       ecorr5=energia(5)
 924       ecorr6=energia(6)
 925       eel_loc=energia(7)
 926       eello_turn3=energia(8)
 927       eello_turn4=energia(9)
 928       eello_turn6=energia(10)
 929       ebe=energia(11)
 930       escloc=energia(12)
 931       etors=energia(13)
 932       etors_d=energia(14)
 933       ehpb=energia(15)
 934       edihcnstr=energia(19)
 935       estr=energia(17)
 936       Uconst=energia(20)
 937       esccor=energia(21)
 938 #ifdef SPLITELE
 939       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 940      &  estr,wbond,ebe,wang,
 941      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 942      &  ecorr,wcorr,
 943      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 944      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 945      &  edihcnstr,ebr*nss,
 946      &  Uconst,etot
 947    10 format (/'Virtual-chain energies:'//
 948      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 949      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 950      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 951      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 952      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 953      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 954      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 955      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 956      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 957      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 958      & ' (SS bridges & dist. cnstr.)'/
 959      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 960      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 961      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 962      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 963      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 964      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 965      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 966      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 967      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 968      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 969      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 970      & 'ETOT=  ',1pE16.6,' (total)')
 971 #else
 972       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 973      &  estr,wbond,ebe,wang,
 974      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 975      &  ecorr,wcorr,
 976      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 977      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
 978      &  ebr*nss,Uconst,etot
 979    10 format (/'Virtual-chain energies:'//
 980      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 981      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 982      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 983      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 984      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 985      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 986      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 987      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 988      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 989      & ' (SS bridges & dist. cnstr.)'/
 990      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 991      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 992      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 993      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 994      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 995      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 996      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 997      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 998      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 999      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1000      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1001      & 'ETOT=  ',1pE16.6,' (total)')
1002 #endif
1003       return
1004       end
1005 C-----------------------------------------------------------------------
1006       subroutine elj(evdw,evdw_p,evdw_m)
1007 C
1008 C This subroutine calculates the interaction energy of nonbonded side chains
1009 C assuming the LJ potential of interaction.
1010 C
1011       implicit real*8 (a-h,o-z)
1012       include 'DIMENSIONS'
1013       parameter (accur=1.0d-10)
1014       include 'COMMON.GEO'
1015       include 'COMMON.VAR'
1016       include 'COMMON.LOCAL'
1017       include 'COMMON.CHAIN'
1018       include 'COMMON.DERIV'
1019       include 'COMMON.INTERACT'
1020       include 'COMMON.TORSION'
1021       include 'COMMON.SBRIDGE'
1022       include 'COMMON.NAMES'
1023       include 'COMMON.IOUNITS'
1024       include 'COMMON.CONTACTS'
1025       dimension gg(3)
1026 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1027       evdw=0.0D0
1028       do i=iatsc_s,iatsc_e
1029         itypi=itype(i)
1030         itypi1=itype(i+1)
1031         xi=c(1,nres+i)
1032         yi=c(2,nres+i)
1033         zi=c(3,nres+i)
1034 C Change 12/1/95
1035         num_conti=0
1036 C
1037 C Calculate SC interaction energy.
1038 C
1039         do iint=1,nint_gr(i)
1040 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1041 cd   &                  'iend=',iend(i,iint)
1042           do j=istart(i,iint),iend(i,iint)
1043             itypj=itype(j)
1044             xj=c(1,nres+j)-xi
1045             yj=c(2,nres+j)-yi
1046             zj=c(3,nres+j)-zi
1047 C Change 12/1/95 to calculate four-body interactions
1048             rij=xj*xj+yj*yj+zj*zj
1049             rrij=1.0D0/rij
1050 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1051             eps0ij=eps(itypi,itypj)
1052             fac=rrij**expon2
1053             e1=fac*fac*aa(itypi,itypj)
1054             e2=fac*bb(itypi,itypj)
1055             evdwij=e1+e2
1056 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1057 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1058 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1059 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1060 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1061 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1062 #ifdef TSCSC
1063             if (bb(itypi,itypj).gt.0) then
1064                evdw_p=evdw_p+evdwij
1065             else
1066                evdw_m=evdw_m+evdwij
1067             endif
1068 #else
1069             evdw=evdw+evdwij
1070 #endif
1071 C
1072 C Calculate the components of the gradient in DC and X
1073 C
1074             fac=-rrij*(e1+evdwij)
1075             gg(1)=xj*fac
1076             gg(2)=yj*fac
1077             gg(3)=zj*fac
1078 #ifdef TSCSC
1079             if (bb(itypi,itypj).gt.0.0d0) then
1080               do k=1,3
1081                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1082                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1083                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1084                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1085               enddo
1086             else
1087               do k=1,3
1088                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1089                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1090                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1091                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1092               enddo
1093             endif
1094 #else
1095             do k=1,3
1096               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1097               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1098               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1099               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1100             enddo
1101 #endif
1102 cgrad            do k=i,j-1
1103 cgrad              do l=1,3
1104 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1105 cgrad              enddo
1106 cgrad            enddo
1107 C
1108 C 12/1/95, revised on 5/20/97
1109 C
1110 C Calculate the contact function. The ith column of the array JCONT will
1111 C contain the numbers of atoms that make contacts with the atom I (of numbers
1112 C greater than I). The arrays FACONT and GACONT will contain the values of
1113 C the contact function and its derivative.
1114 C
1115 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1116 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1117 C Uncomment next line, if the correlation interactions are contact function only
1118             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1119               rij=dsqrt(rij)
1120               sigij=sigma(itypi,itypj)
1121               r0ij=rs0(itypi,itypj)
1122 C
1123 C Check whether the SC's are not too far to make a contact.
1124 C
1125               rcut=1.5d0*r0ij
1126               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1127 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1128 C
1129               if (fcont.gt.0.0D0) then
1130 C If the SC-SC distance if close to sigma, apply spline.
1131 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1132 cAdam &             fcont1,fprimcont1)
1133 cAdam           fcont1=1.0d0-fcont1
1134 cAdam           if (fcont1.gt.0.0d0) then
1135 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1136 cAdam             fcont=fcont*fcont1
1137 cAdam           endif
1138 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1139 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1140 cga             do k=1,3
1141 cga               gg(k)=gg(k)*eps0ij
1142 cga             enddo
1143 cga             eps0ij=-evdwij*eps0ij
1144 C Uncomment for AL's type of SC correlation interactions.
1145 cadam           eps0ij=-evdwij
1146                 num_conti=num_conti+1
1147                 jcont(num_conti,i)=j
1148                 facont(num_conti,i)=fcont*eps0ij
1149                 fprimcont=eps0ij*fprimcont/rij
1150                 fcont=expon*fcont
1151 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1152 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1153 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1154 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1155                 gacont(1,num_conti,i)=-fprimcont*xj
1156                 gacont(2,num_conti,i)=-fprimcont*yj
1157                 gacont(3,num_conti,i)=-fprimcont*zj
1158 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1159 cd              write (iout,'(2i3,3f10.5)')
1160 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1161               endif
1162             endif
1163           enddo      ! j
1164         enddo        ! iint
1165 C Change 12/1/95
1166         num_cont(i)=num_conti
1167       enddo          ! i
1168       do i=1,nct
1169         do j=1,3
1170           gvdwc(j,i)=expon*gvdwc(j,i)
1171           gvdwx(j,i)=expon*gvdwx(j,i)
1172         enddo
1173       enddo
1174 C******************************************************************************
1175 C
1176 C                              N O T E !!!
1177 C
1178 C To save time, the factor of EXPON has been extracted from ALL components
1179 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1180 C use!
1181 C
1182 C******************************************************************************
1183       return
1184       end
1185 C-----------------------------------------------------------------------------
1186       subroutine eljk(evdw,evdw_p,evdw_m)
1187 C
1188 C This subroutine calculates the interaction energy of nonbonded side chains
1189 C assuming the LJK potential of interaction.
1190 C
1191       implicit real*8 (a-h,o-z)
1192       include 'DIMENSIONS'
1193       include 'COMMON.GEO'
1194       include 'COMMON.VAR'
1195       include 'COMMON.LOCAL'
1196       include 'COMMON.CHAIN'
1197       include 'COMMON.DERIV'
1198       include 'COMMON.INTERACT'
1199       include 'COMMON.IOUNITS'
1200       include 'COMMON.NAMES'
1201       dimension gg(3)
1202       logical scheck
1203 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1204       evdw=0.0D0
1205       do i=iatsc_s,iatsc_e
1206         itypi=itype(i)
1207         itypi1=itype(i+1)
1208         xi=c(1,nres+i)
1209         yi=c(2,nres+i)
1210         zi=c(3,nres+i)
1211 C
1212 C Calculate SC interaction energy.
1213 C
1214         do iint=1,nint_gr(i)
1215           do j=istart(i,iint),iend(i,iint)
1216             itypj=itype(j)
1217             xj=c(1,nres+j)-xi
1218             yj=c(2,nres+j)-yi
1219             zj=c(3,nres+j)-zi
1220             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1221             fac_augm=rrij**expon
1222             e_augm=augm(itypi,itypj)*fac_augm
1223             r_inv_ij=dsqrt(rrij)
1224             rij=1.0D0/r_inv_ij
1225             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1226             fac=r_shift_inv**expon
1227             e1=fac*fac*aa(itypi,itypj)
1228             e2=fac*bb(itypi,itypj)
1229             evdwij=e_augm+e1+e2
1230 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1231 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1232 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1233 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1234 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1235 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1236 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1237 #ifdef TSCSC
1238             if (bb(itypi,itypj).gt.0) then
1239                evdw_p=evdw_p+evdwij
1240             else
1241                evdw_m=evdw_m+evdwij
1242             endif
1243 #else
1244             evdw=evdw+evdwij
1245 #endif
1246 C
1247 C Calculate the components of the gradient in DC and X
1248 C
1249             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1250             gg(1)=xj*fac
1251             gg(2)=yj*fac
1252             gg(3)=zj*fac
1253 #ifdef TSCSC
1254             if (bb(itypi,itypj).gt.0.0d0) then
1255               do k=1,3
1256                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1257                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1258                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1259                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1260               enddo
1261             else
1262               do k=1,3
1263                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1264                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1265                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1266                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1267               enddo
1268             endif
1269 #else
1270             do k=1,3
1271               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1272               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1273               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1274               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1275             enddo
1276 #endif
1277 cgrad            do k=i,j-1
1278 cgrad              do l=1,3
1279 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1280 cgrad              enddo
1281 cgrad            enddo
1282           enddo      ! j
1283         enddo        ! iint
1284       enddo          ! i
1285       do i=1,nct
1286         do j=1,3
1287           gvdwc(j,i)=expon*gvdwc(j,i)
1288           gvdwx(j,i)=expon*gvdwx(j,i)
1289         enddo
1290       enddo
1291       return
1292       end
1293 C-----------------------------------------------------------------------------
1294       subroutine ebp(evdw,evdw_p,evdw_m)
1295 C
1296 C This subroutine calculates the interaction energy of nonbonded side chains
1297 C assuming the Berne-Pechukas potential of interaction.
1298 C
1299       implicit real*8 (a-h,o-z)
1300       include 'DIMENSIONS'
1301       include 'COMMON.GEO'
1302       include 'COMMON.VAR'
1303       include 'COMMON.LOCAL'
1304       include 'COMMON.CHAIN'
1305       include 'COMMON.DERIV'
1306       include 'COMMON.NAMES'
1307       include 'COMMON.INTERACT'
1308       include 'COMMON.IOUNITS'
1309       include 'COMMON.CALC'
1310       common /srutu/ icall
1311 c     double precision rrsave(maxdim)
1312       logical lprn
1313       evdw=0.0D0
1314 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1315       evdw=0.0D0
1316 c     if (icall.eq.0) then
1317 c       lprn=.true.
1318 c     else
1319         lprn=.false.
1320 c     endif
1321       ind=0
1322       do i=iatsc_s,iatsc_e
1323         itypi=itype(i)
1324         itypi1=itype(i+1)
1325         xi=c(1,nres+i)
1326         yi=c(2,nres+i)
1327         zi=c(3,nres+i)
1328         dxi=dc_norm(1,nres+i)
1329         dyi=dc_norm(2,nres+i)
1330         dzi=dc_norm(3,nres+i)
1331 c        dsci_inv=dsc_inv(itypi)
1332         dsci_inv=vbld_inv(i+nres)
1333 C
1334 C Calculate SC interaction energy.
1335 C
1336         do iint=1,nint_gr(i)
1337           do j=istart(i,iint),iend(i,iint)
1338             ind=ind+1
1339             itypj=itype(j)
1340 c            dscj_inv=dsc_inv(itypj)
1341             dscj_inv=vbld_inv(j+nres)
1342             chi1=chi(itypi,itypj)
1343             chi2=chi(itypj,itypi)
1344             chi12=chi1*chi2
1345             chip1=chip(itypi)
1346             chip2=chip(itypj)
1347             chip12=chip1*chip2
1348             alf1=alp(itypi)
1349             alf2=alp(itypj)
1350             alf12=0.5D0*(alf1+alf2)
1351 C For diagnostics only!!!
1352 c           chi1=0.0D0
1353 c           chi2=0.0D0
1354 c           chi12=0.0D0
1355 c           chip1=0.0D0
1356 c           chip2=0.0D0
1357 c           chip12=0.0D0
1358 c           alf1=0.0D0
1359 c           alf2=0.0D0
1360 c           alf12=0.0D0
1361             xj=c(1,nres+j)-xi
1362             yj=c(2,nres+j)-yi
1363             zj=c(3,nres+j)-zi
1364             dxj=dc_norm(1,nres+j)
1365             dyj=dc_norm(2,nres+j)
1366             dzj=dc_norm(3,nres+j)
1367             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1368 cd          if (icall.eq.0) then
1369 cd            rrsave(ind)=rrij
1370 cd          else
1371 cd            rrij=rrsave(ind)
1372 cd          endif
1373             rij=dsqrt(rrij)
1374 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1375             call sc_angular
1376 C Calculate whole angle-dependent part of epsilon and contributions
1377 C to its derivatives
1378             fac=(rrij*sigsq)**expon2
1379             e1=fac*fac*aa(itypi,itypj)
1380             e2=fac*bb(itypi,itypj)
1381             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1382             eps2der=evdwij*eps3rt
1383             eps3der=evdwij*eps2rt
1384             evdwij=evdwij*eps2rt*eps3rt
1385 #ifdef TSCSC
1386             if (bb(itypi,itypj).gt.0) then
1387                evdw_p=evdw_p+evdwij
1388             else
1389                evdw_m=evdw_m+evdwij
1390             endif
1391 #else
1392             evdw=evdw+evdwij
1393 #endif
1394             if (lprn) then
1395             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1396             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1397 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1398 cd     &        restyp(itypi),i,restyp(itypj),j,
1399 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1400 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1401 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1402 cd     &        evdwij
1403             endif
1404 C Calculate gradient components.
1405             e1=e1*eps1*eps2rt**2*eps3rt**2
1406             fac=-expon*(e1+evdwij)
1407             sigder=fac/sigsq
1408             fac=rrij*fac
1409 C Calculate radial part of the gradient
1410             gg(1)=xj*fac
1411             gg(2)=yj*fac
1412             gg(3)=zj*fac
1413 C Calculate the angular part of the gradient and sum add the contributions
1414 C to the appropriate components of the Cartesian gradient.
1415 #ifdef TSCSC
1416             if (bb(itypi,itypj).gt.0) then
1417                call sc_grad
1418             else
1419                call sc_grad_T
1420             endif
1421 #else
1422             call sc_grad
1423 #endif
1424           enddo      ! j
1425         enddo        ! iint
1426       enddo          ! i
1427 c     stop
1428       return
1429       end
1430 C-----------------------------------------------------------------------------
1431       subroutine egb(evdw,evdw_p,evdw_m)
1432 C
1433 C This subroutine calculates the interaction energy of nonbonded side chains
1434 C assuming the Gay-Berne potential of interaction.
1435 C
1436       implicit real*8 (a-h,o-z)
1437       include 'DIMENSIONS'
1438       include 'COMMON.GEO'
1439       include 'COMMON.VAR'
1440       include 'COMMON.LOCAL'
1441       include 'COMMON.CHAIN'
1442       include 'COMMON.DERIV'
1443       include 'COMMON.NAMES'
1444       include 'COMMON.INTERACT'
1445       include 'COMMON.IOUNITS'
1446       include 'COMMON.CALC'
1447       include 'COMMON.CONTROL'
1448       logical lprn
1449       evdw=0.0D0
1450 ccccc      energy_dec=.false.
1451 c      write(iout,*) 'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1452       evdw=0.0D0
1453       evdw_p=0.0D0
1454       evdw_m=0.0D0
1455       lprn=.false.
1456 c     if (icall.eq.0) lprn=.false.
1457       ind=0
1458       do i=iatsc_s,iatsc_e
1459         itypi=itype(i)
1460         itypi1=itype(i+1)
1461         xi=c(1,nres+i)
1462         yi=c(2,nres+i)
1463         zi=c(3,nres+i)
1464         dxi=dc_norm(1,nres+i)
1465         dyi=dc_norm(2,nres+i)
1466         dzi=dc_norm(3,nres+i)
1467 c        dsci_inv=dsc_inv(itypi)
1468         dsci_inv=vbld_inv(i+nres)
1469 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1470 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1471 C
1472 C Calculate SC interaction energy.
1473 C
1474         do iint=1,nint_gr(i)
1475           do j=istart(i,iint),iend(i,iint)
1476             ind=ind+1
1477             itypj=itype(j)
1478 c            dscj_inv=dsc_inv(itypj)
1479             dscj_inv=vbld_inv(j+nres)
1480 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1481 c     &       1.0d0/vbld(j+nres)
1482 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1483             sig0ij=sigma(itypi,itypj)
1484             chi1=chi(itypi,itypj)
1485             chi2=chi(itypj,itypi)
1486             chi12=chi1*chi2
1487             chip1=chip(itypi)
1488             chip2=chip(itypj)
1489             chip12=chip1*chip2
1490             alf1=alp(itypi)
1491             alf2=alp(itypj)
1492             alf12=0.5D0*(alf1+alf2)
1493 C For diagnostics only!!!
1494 c           chi1=0.0D0
1495 c           chi2=0.0D0
1496 c           chi12=0.0D0
1497 c           chip1=0.0D0
1498 c           chip2=0.0D0
1499 c           chip12=0.0D0
1500 c           alf1=0.0D0
1501 c           alf2=0.0D0
1502 c           alf12=0.0D0
1503             xj=c(1,nres+j)-xi
1504             yj=c(2,nres+j)-yi
1505             zj=c(3,nres+j)-zi
1506             dxj=dc_norm(1,nres+j)
1507             dyj=dc_norm(2,nres+j)
1508             dzj=dc_norm(3,nres+j)
1509 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1510 c            write (iout,*) "j",j," dc_norm",
1511 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1512             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1513             rij=dsqrt(rrij)
1514 C Calculate angle-dependent terms of energy and contributions to their
1515 C derivatives.
1516             call sc_angular
1517             sigsq=1.0D0/sigsq
1518             sig=sig0ij*dsqrt(sigsq)
1519             rij_shift=1.0D0/rij-sig+sig0ij
1520 c for diagnostics; uncomment
1521 c            rij_shift=1.2*sig0ij
1522 C I hate to put IF's in the loops, but here don't have another choice!!!!
1523             if (rij_shift.le.0.0D0) then
1524               evdw=1.0D20
1525 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1526 cd     &        restyp(itypi),i,restyp(itypj),j,
1527 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1528               return
1529             endif
1530             sigder=-sig*sigsq
1531 c---------------------------------------------------------------
1532             rij_shift=1.0D0/rij_shift
1533             fac=rij_shift**expon
1534             e1=fac*fac*aa(itypi,itypj)
1535             e2=fac*bb(itypi,itypj)
1536             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1537             eps2der=evdwij*eps3rt
1538             eps3der=evdwij*eps2rt
1539 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1540 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1541             evdwij=evdwij*eps2rt*eps3rt
1542 #ifdef TSCSC
1543             if (bb(itypi,itypj).gt.0) then
1544                evdw_p=evdw_p+evdwij
1545             else
1546                evdw_m=evdw_m+evdwij
1547             endif
1548 #else
1549             evdw=evdw+evdwij
1550 #endif
1551             if (lprn) then
1552             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1553             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1554             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1555      &        restyp(itypi),i,restyp(itypj),j,
1556      &        epsi,sigm,chi1,chi2,chip1,chip2,
1557      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1558      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1559      &        evdwij
1560             endif
1561
1562             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1563      &                        'evdw',i,j,evdwij
1564
1565 C Calculate gradient components.
1566             e1=e1*eps1*eps2rt**2*eps3rt**2
1567             fac=-expon*(e1+evdwij)*rij_shift
1568             sigder=fac*sigder
1569             fac=rij*fac
1570 c            fac=0.0d0
1571 C Calculate the radial part of the gradient
1572             gg(1)=xj*fac
1573             gg(2)=yj*fac
1574             gg(3)=zj*fac
1575 C Calculate angular part of the gradient.
1576 #ifdef TSCSC
1577             if (bb(itypi,itypj).gt.0) then
1578                call sc_grad
1579             else
1580                call sc_grad_T
1581             endif
1582 #else
1583             call sc_grad
1584 #endif
1585           enddo      ! j
1586         enddo        ! iint
1587       enddo          ! i
1588 c      write (iout,*) "Number of loop steps in EGB:",ind
1589 cccc      energy_dec=.false.
1590       return
1591       end
1592 C-----------------------------------------------------------------------------
1593       subroutine egbv(evdw,evdw_p,evdw_m)
1594 C
1595 C This subroutine calculates the interaction energy of nonbonded side chains
1596 C assuming the Gay-Berne-Vorobjev potential of interaction.
1597 C
1598       implicit real*8 (a-h,o-z)
1599       include 'DIMENSIONS'
1600       include 'COMMON.GEO'
1601       include 'COMMON.VAR'
1602       include 'COMMON.LOCAL'
1603       include 'COMMON.CHAIN'
1604       include 'COMMON.DERIV'
1605       include 'COMMON.NAMES'
1606       include 'COMMON.INTERACT'
1607       include 'COMMON.IOUNITS'
1608       include 'COMMON.CALC'
1609       common /srutu/ icall
1610       logical lprn
1611       evdw=0.0D0
1612 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1613       evdw=0.0D0
1614       lprn=.false.
1615 c     if (icall.eq.0) lprn=.true.
1616       ind=0
1617       do i=iatsc_s,iatsc_e
1618         itypi=itype(i)
1619         itypi1=itype(i+1)
1620         xi=c(1,nres+i)
1621         yi=c(2,nres+i)
1622         zi=c(3,nres+i)
1623         dxi=dc_norm(1,nres+i)
1624         dyi=dc_norm(2,nres+i)
1625         dzi=dc_norm(3,nres+i)
1626 c        dsci_inv=dsc_inv(itypi)
1627         dsci_inv=vbld_inv(i+nres)
1628 C
1629 C Calculate SC interaction energy.
1630 C
1631         do iint=1,nint_gr(i)
1632           do j=istart(i,iint),iend(i,iint)
1633             ind=ind+1
1634             itypj=itype(j)
1635 c            dscj_inv=dsc_inv(itypj)
1636             dscj_inv=vbld_inv(j+nres)
1637             sig0ij=sigma(itypi,itypj)
1638             r0ij=r0(itypi,itypj)
1639             chi1=chi(itypi,itypj)
1640             chi2=chi(itypj,itypi)
1641             chi12=chi1*chi2
1642             chip1=chip(itypi)
1643             chip2=chip(itypj)
1644             chip12=chip1*chip2
1645             alf1=alp(itypi)
1646             alf2=alp(itypj)
1647             alf12=0.5D0*(alf1+alf2)
1648 C For diagnostics only!!!
1649 c           chi1=0.0D0
1650 c           chi2=0.0D0
1651 c           chi12=0.0D0
1652 c           chip1=0.0D0
1653 c           chip2=0.0D0
1654 c           chip12=0.0D0
1655 c           alf1=0.0D0
1656 c           alf2=0.0D0
1657 c           alf12=0.0D0
1658             xj=c(1,nres+j)-xi
1659             yj=c(2,nres+j)-yi
1660             zj=c(3,nres+j)-zi
1661             dxj=dc_norm(1,nres+j)
1662             dyj=dc_norm(2,nres+j)
1663             dzj=dc_norm(3,nres+j)
1664             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1665             rij=dsqrt(rrij)
1666 C Calculate angle-dependent terms of energy and contributions to their
1667 C derivatives.
1668             call sc_angular
1669             sigsq=1.0D0/sigsq
1670             sig=sig0ij*dsqrt(sigsq)
1671             rij_shift=1.0D0/rij-sig+r0ij
1672 C I hate to put IF's in the loops, but here don't have another choice!!!!
1673             if (rij_shift.le.0.0D0) then
1674               evdw=1.0D20
1675               return
1676             endif
1677             sigder=-sig*sigsq
1678 c---------------------------------------------------------------
1679             rij_shift=1.0D0/rij_shift
1680             fac=rij_shift**expon
1681             e1=fac*fac*aa(itypi,itypj)
1682             e2=fac*bb(itypi,itypj)
1683             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1684             eps2der=evdwij*eps3rt
1685             eps3der=evdwij*eps2rt
1686             fac_augm=rrij**expon
1687             e_augm=augm(itypi,itypj)*fac_augm
1688             evdwij=evdwij*eps2rt*eps3rt
1689 #ifdef TSCSC
1690             if (bb(itypi,itypj).gt.0) then
1691                evdw_p=evdw_p+evdwij+e_augm
1692             else
1693                evdw_m=evdw_m+evdwij+e_augm
1694             endif
1695 #else
1696             evdw=evdw+evdwij+e_augm
1697 #endif
1698             if (lprn) then
1699             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1700             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1701             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1702      &        restyp(itypi),i,restyp(itypj),j,
1703      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1704      &        chi1,chi2,chip1,chip2,
1705      &        eps1,eps2rt**2,eps3rt**2,
1706      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1707      &        evdwij+e_augm
1708             endif
1709 C Calculate gradient components.
1710             e1=e1*eps1*eps2rt**2*eps3rt**2
1711             fac=-expon*(e1+evdwij)*rij_shift
1712             sigder=fac*sigder
1713             fac=rij*fac-2*expon*rrij*e_augm
1714 C Calculate the radial part of the gradient
1715             gg(1)=xj*fac
1716             gg(2)=yj*fac
1717             gg(3)=zj*fac
1718 C Calculate angular part of the gradient.
1719 #ifdef TSCSC
1720             if (bb(itypi,itypj).gt.0) then
1721                call sc_grad
1722             else
1723                call sc_grad_T
1724             endif
1725 #else
1726             call sc_grad
1727 #endif
1728           enddo      ! j
1729         enddo        ! iint
1730       enddo          ! i
1731       end
1732 C-----------------------------------------------------------------------------
1733       subroutine sc_angular
1734 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1735 C om12. Called by ebp, egb, and egbv.
1736       implicit none
1737       include 'COMMON.CALC'
1738       include 'COMMON.IOUNITS'
1739       erij(1)=xj*rij
1740       erij(2)=yj*rij
1741       erij(3)=zj*rij
1742       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1743       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1744       om12=dxi*dxj+dyi*dyj+dzi*dzj
1745       chiom12=chi12*om12
1746 C Calculate eps1(om12) and its derivative in om12
1747       faceps1=1.0D0-om12*chiom12
1748       faceps1_inv=1.0D0/faceps1
1749       eps1=dsqrt(faceps1_inv)
1750 C Following variable is eps1*deps1/dom12
1751       eps1_om12=faceps1_inv*chiom12
1752 c diagnostics only
1753 c      faceps1_inv=om12
1754 c      eps1=om12
1755 c      eps1_om12=1.0d0
1756 c      write (iout,*) "om12",om12," eps1",eps1
1757 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1758 C and om12.
1759       om1om2=om1*om2
1760       chiom1=chi1*om1
1761       chiom2=chi2*om2
1762       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1763       sigsq=1.0D0-facsig*faceps1_inv
1764       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1765       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1766       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1767 c diagnostics only
1768 c      sigsq=1.0d0
1769 c      sigsq_om1=0.0d0
1770 c      sigsq_om2=0.0d0
1771 c      sigsq_om12=0.0d0
1772 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1773 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1774 c     &    " eps1",eps1
1775 C Calculate eps2 and its derivatives in om1, om2, and om12.
1776       chipom1=chip1*om1
1777       chipom2=chip2*om2
1778       chipom12=chip12*om12
1779       facp=1.0D0-om12*chipom12
1780       facp_inv=1.0D0/facp
1781       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1782 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1783 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1784 C Following variable is the square root of eps2
1785       eps2rt=1.0D0-facp1*facp_inv
1786 C Following three variables are the derivatives of the square root of eps
1787 C in om1, om2, and om12.
1788       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1789       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1790       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1791 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1792       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1793 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1794 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1795 c     &  " eps2rt_om12",eps2rt_om12
1796 C Calculate whole angle-dependent part of epsilon and contributions
1797 C to its derivatives
1798       return
1799       end
1800
1801 C----------------------------------------------------------------------------
1802       subroutine sc_grad_T
1803       implicit real*8 (a-h,o-z)
1804       include 'DIMENSIONS'
1805       include 'COMMON.CHAIN'
1806       include 'COMMON.DERIV'
1807       include 'COMMON.CALC'
1808       include 'COMMON.IOUNITS'
1809       double precision dcosom1(3),dcosom2(3)
1810       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1811       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1812       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1813      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1814 c diagnostics only
1815 c      eom1=0.0d0
1816 c      eom2=0.0d0
1817 c      eom12=evdwij*eps1_om12
1818 c end diagnostics
1819 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1820 c     &  " sigder",sigder
1821 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1822 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1823       do k=1,3
1824         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1825         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1826       enddo
1827       do k=1,3
1828         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1829       enddo
1830 c      write (iout,*) "gg",(gg(k),k=1,3)
1831       do k=1,3
1832         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1833      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1834      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1835         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1836      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1837      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1838 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1839 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1840 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1841 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1842       enddo
1843 C
1844 C Calculate the components of the gradient in DC and X
1845 C
1846 cgrad      do k=i,j-1
1847 cgrad        do l=1,3
1848 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1849 cgrad        enddo
1850 cgrad      enddo
1851       do l=1,3
1852         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1853         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1854       enddo
1855       return
1856       end
1857
1858 C----------------------------------------------------------------------------
1859       subroutine sc_grad
1860       implicit real*8 (a-h,o-z)
1861       include 'DIMENSIONS'
1862       include 'COMMON.CHAIN'
1863       include 'COMMON.DERIV'
1864       include 'COMMON.CALC'
1865       include 'COMMON.IOUNITS'
1866       double precision dcosom1(3),dcosom2(3)
1867       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1868       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1869       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1870      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1871 c diagnostics only
1872 c      eom1=0.0d0
1873 c      eom2=0.0d0
1874 c      eom12=evdwij*eps1_om12
1875 c end diagnostics
1876 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1877 c     &  " sigder",sigder
1878 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1879 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1880       do k=1,3
1881         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1882         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1883       enddo
1884       do k=1,3
1885         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1886       enddo
1887 c      write (iout,*) "gg",(gg(k),k=1,3)
1888       do k=1,3
1889         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1890      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1891      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1892         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1893      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1894      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1895 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1896 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1897 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1898 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1899       enddo
1900 C
1901 C Calculate the components of the gradient in DC and X
1902 C
1903 cgrad      do k=i,j-1
1904 cgrad        do l=1,3
1905 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1906 cgrad        enddo
1907 cgrad      enddo
1908       do l=1,3
1909         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1910         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1911       enddo
1912       return
1913       end
1914 C-----------------------------------------------------------------------
1915       subroutine e_softsphere(evdw)
1916 C
1917 C This subroutine calculates the interaction energy of nonbonded side chains
1918 C assuming the LJ potential of interaction.
1919 C
1920       implicit real*8 (a-h,o-z)
1921       include 'DIMENSIONS'
1922       parameter (accur=1.0d-10)
1923       include 'COMMON.GEO'
1924       include 'COMMON.VAR'
1925       include 'COMMON.LOCAL'
1926       include 'COMMON.CHAIN'
1927       include 'COMMON.DERIV'
1928       include 'COMMON.INTERACT'
1929       include 'COMMON.TORSION'
1930       include 'COMMON.SBRIDGE'
1931       include 'COMMON.NAMES'
1932       include 'COMMON.IOUNITS'
1933       include 'COMMON.CONTACTS'
1934       dimension gg(3)
1935 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1936       evdw=0.0D0
1937       do i=iatsc_s,iatsc_e
1938         itypi=itype(i)
1939         itypi1=itype(i+1)
1940         xi=c(1,nres+i)
1941         yi=c(2,nres+i)
1942         zi=c(3,nres+i)
1943 C
1944 C Calculate SC interaction energy.
1945 C
1946         do iint=1,nint_gr(i)
1947 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1948 cd   &                  'iend=',iend(i,iint)
1949           do j=istart(i,iint),iend(i,iint)
1950             itypj=itype(j)
1951             xj=c(1,nres+j)-xi
1952             yj=c(2,nres+j)-yi
1953             zj=c(3,nres+j)-zi
1954             rij=xj*xj+yj*yj+zj*zj
1955 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1956             r0ij=r0(itypi,itypj)
1957             r0ijsq=r0ij*r0ij
1958 c            print *,i,j,r0ij,dsqrt(rij)
1959             if (rij.lt.r0ijsq) then
1960               evdwij=0.25d0*(rij-r0ijsq)**2
1961               fac=rij-r0ijsq
1962             else
1963               evdwij=0.0d0
1964               fac=0.0d0
1965             endif
1966             evdw=evdw+evdwij
1967 C
1968 C Calculate the components of the gradient in DC and X
1969 C
1970             gg(1)=xj*fac
1971             gg(2)=yj*fac
1972             gg(3)=zj*fac
1973             do k=1,3
1974               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1975               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1976               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1977               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1978             enddo
1979 cgrad            do k=i,j-1
1980 cgrad              do l=1,3
1981 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1982 cgrad              enddo
1983 cgrad            enddo
1984           enddo ! j
1985         enddo ! iint
1986       enddo ! i
1987       return
1988       end
1989 C--------------------------------------------------------------------------
1990       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1991      &              eello_turn4)
1992 C
1993 C Soft-sphere potential of p-p interaction
1994 C
1995       implicit real*8 (a-h,o-z)
1996       include 'DIMENSIONS'
1997       include 'COMMON.CONTROL'
1998       include 'COMMON.IOUNITS'
1999       include 'COMMON.GEO'
2000       include 'COMMON.VAR'
2001       include 'COMMON.LOCAL'
2002       include 'COMMON.CHAIN'
2003       include 'COMMON.DERIV'
2004       include 'COMMON.INTERACT'
2005       include 'COMMON.CONTACTS'
2006       include 'COMMON.TORSION'
2007       include 'COMMON.VECTORS'
2008       include 'COMMON.FFIELD'
2009       dimension ggg(3)
2010 cd      write(iout,*) 'In EELEC_soft_sphere'
2011       ees=0.0D0
2012       evdw1=0.0D0
2013       eel_loc=0.0d0
2014       eello_turn3=0.0d0
2015       eello_turn4=0.0d0
2016       ind=0
2017       do i=iatel_s,iatel_e
2018         dxi=dc(1,i)
2019         dyi=dc(2,i)
2020         dzi=dc(3,i)
2021         xmedi=c(1,i)+0.5d0*dxi
2022         ymedi=c(2,i)+0.5d0*dyi
2023         zmedi=c(3,i)+0.5d0*dzi
2024         num_conti=0
2025 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2026         do j=ielstart(i),ielend(i)
2027           ind=ind+1
2028           iteli=itel(i)
2029           itelj=itel(j)
2030           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2031           r0ij=rpp(iteli,itelj)
2032           r0ijsq=r0ij*r0ij
2033           dxj=dc(1,j)
2034           dyj=dc(2,j)
2035           dzj=dc(3,j)
2036           xj=c(1,j)+0.5D0*dxj-xmedi
2037           yj=c(2,j)+0.5D0*dyj-ymedi
2038           zj=c(3,j)+0.5D0*dzj-zmedi
2039           rij=xj*xj+yj*yj+zj*zj
2040           if (rij.lt.r0ijsq) then
2041             evdw1ij=0.25d0*(rij-r0ijsq)**2
2042             fac=rij-r0ijsq
2043           else
2044             evdw1ij=0.0d0
2045             fac=0.0d0
2046           endif
2047           evdw1=evdw1+evdw1ij
2048 C
2049 C Calculate contributions to the Cartesian gradient.
2050 C
2051           ggg(1)=fac*xj
2052           ggg(2)=fac*yj
2053           ggg(3)=fac*zj
2054           do k=1,3
2055             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2056             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2057           enddo
2058 *
2059 * Loop over residues i+1 thru j-1.
2060 *
2061 cgrad          do k=i+1,j-1
2062 cgrad            do l=1,3
2063 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2064 cgrad            enddo
2065 cgrad          enddo
2066         enddo ! j
2067       enddo   ! i
2068 cgrad      do i=nnt,nct-1
2069 cgrad        do k=1,3
2070 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2071 cgrad        enddo
2072 cgrad        do j=i+1,nct-1
2073 cgrad          do k=1,3
2074 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2075 cgrad          enddo
2076 cgrad        enddo
2077 cgrad      enddo
2078       return
2079       end
2080 c------------------------------------------------------------------------------
2081       subroutine vec_and_deriv
2082       implicit real*8 (a-h,o-z)
2083       include 'DIMENSIONS'
2084 #ifdef MPI
2085       include 'mpif.h'
2086 #endif
2087       include 'COMMON.IOUNITS'
2088       include 'COMMON.GEO'
2089       include 'COMMON.VAR'
2090       include 'COMMON.LOCAL'
2091       include 'COMMON.CHAIN'
2092       include 'COMMON.VECTORS'
2093       include 'COMMON.SETUP'
2094       include 'COMMON.TIME1'
2095       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2096 C Compute the local reference systems. For reference system (i), the
2097 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2098 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2099 #ifdef PARVEC
2100       do i=ivec_start,ivec_end
2101 #else
2102       do i=1,nres-1
2103 #endif
2104           if (i.eq.nres-1) then
2105 C Case of the last full residue
2106 C Compute the Z-axis
2107             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2108             costh=dcos(pi-theta(nres))
2109             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2110             do k=1,3
2111               uz(k,i)=fac*uz(k,i)
2112             enddo
2113 C Compute the derivatives of uz
2114             uzder(1,1,1)= 0.0d0
2115             uzder(2,1,1)=-dc_norm(3,i-1)
2116             uzder(3,1,1)= dc_norm(2,i-1)
2117             uzder(1,2,1)= dc_norm(3,i-1)
2118             uzder(2,2,1)= 0.0d0
2119             uzder(3,2,1)=-dc_norm(1,i-1)
2120             uzder(1,3,1)=-dc_norm(2,i-1)
2121             uzder(2,3,1)= dc_norm(1,i-1)
2122             uzder(3,3,1)= 0.0d0
2123             uzder(1,1,2)= 0.0d0
2124             uzder(2,1,2)= dc_norm(3,i)
2125             uzder(3,1,2)=-dc_norm(2,i)
2126             uzder(1,2,2)=-dc_norm(3,i)
2127             uzder(2,2,2)= 0.0d0
2128             uzder(3,2,2)= dc_norm(1,i)
2129             uzder(1,3,2)= dc_norm(2,i)
2130             uzder(2,3,2)=-dc_norm(1,i)
2131             uzder(3,3,2)= 0.0d0
2132 C Compute the Y-axis
2133             facy=fac
2134             do k=1,3
2135               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2136             enddo
2137 C Compute the derivatives of uy
2138             do j=1,3
2139               do k=1,3
2140                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2141      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2142                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2143               enddo
2144               uyder(j,j,1)=uyder(j,j,1)-costh
2145               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2146             enddo
2147             do j=1,2
2148               do k=1,3
2149                 do l=1,3
2150                   uygrad(l,k,j,i)=uyder(l,k,j)
2151                   uzgrad(l,k,j,i)=uzder(l,k,j)
2152                 enddo
2153               enddo
2154             enddo
2155             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2156             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2157             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2158             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2159           else
2160 C Other residues
2161 C Compute the Z-axis
2162             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2163             costh=dcos(pi-theta(i+2))
2164             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2165             do k=1,3
2166               uz(k,i)=fac*uz(k,i)
2167             enddo
2168 C Compute the derivatives of uz
2169             uzder(1,1,1)= 0.0d0
2170             uzder(2,1,1)=-dc_norm(3,i+1)
2171             uzder(3,1,1)= dc_norm(2,i+1)
2172             uzder(1,2,1)= dc_norm(3,i+1)
2173             uzder(2,2,1)= 0.0d0
2174             uzder(3,2,1)=-dc_norm(1,i+1)
2175             uzder(1,3,1)=-dc_norm(2,i+1)
2176             uzder(2,3,1)= dc_norm(1,i+1)
2177             uzder(3,3,1)= 0.0d0
2178             uzder(1,1,2)= 0.0d0
2179             uzder(2,1,2)= dc_norm(3,i)
2180             uzder(3,1,2)=-dc_norm(2,i)
2181             uzder(1,2,2)=-dc_norm(3,i)
2182             uzder(2,2,2)= 0.0d0
2183             uzder(3,2,2)= dc_norm(1,i)
2184             uzder(1,3,2)= dc_norm(2,i)
2185             uzder(2,3,2)=-dc_norm(1,i)
2186             uzder(3,3,2)= 0.0d0
2187 C Compute the Y-axis
2188             facy=fac
2189             do k=1,3
2190               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2191             enddo
2192 C Compute the derivatives of uy
2193             do j=1,3
2194               do k=1,3
2195                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2196      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2197                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2198               enddo
2199               uyder(j,j,1)=uyder(j,j,1)-costh
2200               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2201             enddo
2202             do j=1,2
2203               do k=1,3
2204                 do l=1,3
2205                   uygrad(l,k,j,i)=uyder(l,k,j)
2206                   uzgrad(l,k,j,i)=uzder(l,k,j)
2207                 enddo
2208               enddo
2209             enddo
2210             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2211             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2212             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2213             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2214           endif
2215       enddo
2216       do i=1,nres-1
2217         vbld_inv_temp(1)=vbld_inv(i+1)
2218         if (i.lt.nres-1) then
2219           vbld_inv_temp(2)=vbld_inv(i+2)
2220           else
2221           vbld_inv_temp(2)=vbld_inv(i)
2222           endif
2223         do j=1,2
2224           do k=1,3
2225             do l=1,3
2226               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2227               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2228             enddo
2229           enddo
2230         enddo
2231       enddo
2232 #if defined(PARVEC) && defined(MPI)
2233       if (nfgtasks1.gt.1) then
2234         time00=MPI_Wtime()
2235 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2236 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2237 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2238         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2239      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2240      &   FG_COMM1,IERR)
2241         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2242      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2243      &   FG_COMM1,IERR)
2244         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2245      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2246      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2247         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2248      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2249      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2250         time_gather=time_gather+MPI_Wtime()-time00
2251       endif
2252 c      if (fg_rank.eq.0) then
2253 c        write (iout,*) "Arrays UY and UZ"
2254 c        do i=1,nres-1
2255 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2256 c     &     (uz(k,i),k=1,3)
2257 c        enddo
2258 c      endif
2259 #endif
2260       return
2261       end
2262 C-----------------------------------------------------------------------------
2263       subroutine check_vecgrad
2264       implicit real*8 (a-h,o-z)
2265       include 'DIMENSIONS'
2266       include 'COMMON.IOUNITS'
2267       include 'COMMON.GEO'
2268       include 'COMMON.VAR'
2269       include 'COMMON.LOCAL'
2270       include 'COMMON.CHAIN'
2271       include 'COMMON.VECTORS'
2272       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2273       dimension uyt(3,maxres),uzt(3,maxres)
2274       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2275       double precision delta /1.0d-7/
2276       call vec_and_deriv
2277 cd      do i=1,nres
2278 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2279 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2280 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2281 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2282 cd     &     (dc_norm(if90,i),if90=1,3)
2283 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2284 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2285 cd          write(iout,'(a)')
2286 cd      enddo
2287       do i=1,nres
2288         do j=1,2
2289           do k=1,3
2290             do l=1,3
2291               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2292               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2293             enddo
2294           enddo
2295         enddo
2296       enddo
2297       call vec_and_deriv
2298       do i=1,nres
2299         do j=1,3
2300           uyt(j,i)=uy(j,i)
2301           uzt(j,i)=uz(j,i)
2302         enddo
2303       enddo
2304       do i=1,nres
2305 cd        write (iout,*) 'i=',i
2306         do k=1,3
2307           erij(k)=dc_norm(k,i)
2308         enddo
2309         do j=1,3
2310           do k=1,3
2311             dc_norm(k,i)=erij(k)
2312           enddo
2313           dc_norm(j,i)=dc_norm(j,i)+delta
2314 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2315 c          do k=1,3
2316 c            dc_norm(k,i)=dc_norm(k,i)/fac
2317 c          enddo
2318 c          write (iout,*) (dc_norm(k,i),k=1,3)
2319 c          write (iout,*) (erij(k),k=1,3)
2320           call vec_and_deriv
2321           do k=1,3
2322             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2323             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2324             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2325             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2326           enddo
2327 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2328 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2329 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2330         enddo
2331         do k=1,3
2332           dc_norm(k,i)=erij(k)
2333         enddo
2334 cd        do k=1,3
2335 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2336 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2337 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2338 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2339 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2340 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2341 cd          write (iout,'(a)')
2342 cd        enddo
2343       enddo
2344       return
2345       end
2346 C--------------------------------------------------------------------------
2347       subroutine set_matrices
2348       implicit real*8 (a-h,o-z)
2349       include 'DIMENSIONS'
2350 #ifdef MPI
2351       include "mpif.h"
2352       include "COMMON.SETUP"
2353       integer IERR
2354       integer status(MPI_STATUS_SIZE)
2355 #endif
2356       include 'COMMON.IOUNITS'
2357       include 'COMMON.GEO'
2358       include 'COMMON.VAR'
2359       include 'COMMON.LOCAL'
2360       include 'COMMON.CHAIN'
2361       include 'COMMON.DERIV'
2362       include 'COMMON.INTERACT'
2363       include 'COMMON.CONTACTS'
2364       include 'COMMON.TORSION'
2365       include 'COMMON.VECTORS'
2366       include 'COMMON.FFIELD'
2367       double precision auxvec(2),auxmat(2,2)
2368 C
2369 C Compute the virtual-bond-torsional-angle dependent quantities needed
2370 C to calculate the el-loc multibody terms of various order.
2371 C
2372 #ifdef PARMAT
2373       do i=ivec_start+2,ivec_end+2
2374 #else
2375       do i=3,nres+1
2376 #endif
2377         if (i .lt. nres+1) then
2378           sin1=dsin(phi(i))
2379           cos1=dcos(phi(i))
2380           sintab(i-2)=sin1
2381           costab(i-2)=cos1
2382           obrot(1,i-2)=cos1
2383           obrot(2,i-2)=sin1
2384           sin2=dsin(2*phi(i))
2385           cos2=dcos(2*phi(i))
2386           sintab2(i-2)=sin2
2387           costab2(i-2)=cos2
2388           obrot2(1,i-2)=cos2
2389           obrot2(2,i-2)=sin2
2390           Ug(1,1,i-2)=-cos1
2391           Ug(1,2,i-2)=-sin1
2392           Ug(2,1,i-2)=-sin1
2393           Ug(2,2,i-2)= cos1
2394           Ug2(1,1,i-2)=-cos2
2395           Ug2(1,2,i-2)=-sin2
2396           Ug2(2,1,i-2)=-sin2
2397           Ug2(2,2,i-2)= cos2
2398         else
2399           costab(i-2)=1.0d0
2400           sintab(i-2)=0.0d0
2401           obrot(1,i-2)=1.0d0
2402           obrot(2,i-2)=0.0d0
2403           obrot2(1,i-2)=0.0d0
2404           obrot2(2,i-2)=0.0d0
2405           Ug(1,1,i-2)=1.0d0
2406           Ug(1,2,i-2)=0.0d0
2407           Ug(2,1,i-2)=0.0d0
2408           Ug(2,2,i-2)=1.0d0
2409           Ug2(1,1,i-2)=0.0d0
2410           Ug2(1,2,i-2)=0.0d0
2411           Ug2(2,1,i-2)=0.0d0
2412           Ug2(2,2,i-2)=0.0d0
2413         endif
2414         if (i .gt. 3 .and. i .lt. nres+1) then
2415           obrot_der(1,i-2)=-sin1
2416           obrot_der(2,i-2)= cos1
2417           Ugder(1,1,i-2)= sin1
2418           Ugder(1,2,i-2)=-cos1
2419           Ugder(2,1,i-2)=-cos1
2420           Ugder(2,2,i-2)=-sin1
2421           dwacos2=cos2+cos2
2422           dwasin2=sin2+sin2
2423           obrot2_der(1,i-2)=-dwasin2
2424           obrot2_der(2,i-2)= dwacos2
2425           Ug2der(1,1,i-2)= dwasin2
2426           Ug2der(1,2,i-2)=-dwacos2
2427           Ug2der(2,1,i-2)=-dwacos2
2428           Ug2der(2,2,i-2)=-dwasin2
2429         else
2430           obrot_der(1,i-2)=0.0d0
2431           obrot_der(2,i-2)=0.0d0
2432           Ugder(1,1,i-2)=0.0d0
2433           Ugder(1,2,i-2)=0.0d0
2434           Ugder(2,1,i-2)=0.0d0
2435           Ugder(2,2,i-2)=0.0d0
2436           obrot2_der(1,i-2)=0.0d0
2437           obrot2_der(2,i-2)=0.0d0
2438           Ug2der(1,1,i-2)=0.0d0
2439           Ug2der(1,2,i-2)=0.0d0
2440           Ug2der(2,1,i-2)=0.0d0
2441           Ug2der(2,2,i-2)=0.0d0
2442         endif
2443 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2444         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2445           iti = itortyp(itype(i-2))
2446         else
2447           iti=ntortyp+1
2448         endif
2449 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2450         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2451           iti1 = itortyp(itype(i-1))
2452         else
2453           iti1=ntortyp+1
2454         endif
2455 cd        write (iout,*) '*******i',i,' iti1',iti
2456 cd        write (iout,*) 'b1',b1(:,iti)
2457 cd        write (iout,*) 'b2',b2(:,iti)
2458 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2459 c        if (i .gt. iatel_s+2) then
2460         if (i .gt. nnt+2) then
2461           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2462           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2463           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2464      &    then
2465           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2466           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2467           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2468           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2469           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2470           endif
2471         else
2472           do k=1,2
2473             Ub2(k,i-2)=0.0d0
2474             Ctobr(k,i-2)=0.0d0
2475             Dtobr2(k,i-2)=0.0d0
2476             do l=1,2
2477               EUg(l,k,i-2)=0.0d0
2478               CUg(l,k,i-2)=0.0d0
2479               DUg(l,k,i-2)=0.0d0
2480               DtUg2(l,k,i-2)=0.0d0
2481             enddo
2482           enddo
2483         endif
2484         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2485         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2486         do k=1,2
2487           muder(k,i-2)=Ub2der(k,i-2)
2488         enddo
2489 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2490         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2491           iti1 = itortyp(itype(i-1))
2492         else
2493           iti1=ntortyp+1
2494         endif
2495         do k=1,2
2496           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2497         enddo
2498 cd        write (iout,*) 'mu ',mu(:,i-2)
2499 cd        write (iout,*) 'mu1',mu1(:,i-2)
2500 cd        write (iout,*) 'mu2',mu2(:,i-2)
2501         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2502      &  then
2503         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2504         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2505         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2506         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2507         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2508 C Vectors and matrices dependent on a single virtual-bond dihedral.
2509         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2510         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2511         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2512         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2513         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2514         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2515         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2516         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2517         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2518         endif
2519       enddo
2520 C Matrices dependent on two consecutive virtual-bond dihedrals.
2521 C The order of matrices is from left to right.
2522       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2523      &then
2524 c      do i=max0(ivec_start,2),ivec_end
2525       do i=2,nres-1
2526         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2527         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2528         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2529         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2530         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2531         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2532         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2533         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2534       enddo
2535       endif
2536 #if defined(MPI) && defined(PARMAT)
2537 #ifdef DEBUG
2538 c      if (fg_rank.eq.0) then
2539         write (iout,*) "Arrays UG and UGDER before GATHER"
2540         do i=1,nres-1
2541           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2542      &     ((ug(l,k,i),l=1,2),k=1,2),
2543      &     ((ugder(l,k,i),l=1,2),k=1,2)
2544         enddo
2545         write (iout,*) "Arrays UG2 and UG2DER"
2546         do i=1,nres-1
2547           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2548      &     ((ug2(l,k,i),l=1,2),k=1,2),
2549      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2550         enddo
2551         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2552         do i=1,nres-1
2553           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2554      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2555      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2556         enddo
2557         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2558         do i=1,nres-1
2559           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2560      &     costab(i),sintab(i),costab2(i),sintab2(i)
2561         enddo
2562         write (iout,*) "Array MUDER"
2563         do i=1,nres-1
2564           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2565         enddo
2566 c      endif
2567 #endif
2568       if (nfgtasks.gt.1) then
2569         time00=MPI_Wtime()
2570 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2571 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2572 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2573 #ifdef MATGATHER
2574         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2575      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2576      &   FG_COMM1,IERR)
2577         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2578      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2579      &   FG_COMM1,IERR)
2580         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2581      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2582      &   FG_COMM1,IERR)
2583         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2584      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2585      &   FG_COMM1,IERR)
2586         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2587      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2588      &   FG_COMM1,IERR)
2589         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2590      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2591      &   FG_COMM1,IERR)
2592         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2593      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2594      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2595         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2596      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2597      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2598         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2599      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2600      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2601         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2602      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2603      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2604         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2605      &  then
2606         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2607      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2608      &   FG_COMM1,IERR)
2609         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2610      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2611      &   FG_COMM1,IERR)
2612         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2613      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2614      &   FG_COMM1,IERR)
2615        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2616      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2617      &   FG_COMM1,IERR)
2618         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2619      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2620      &   FG_COMM1,IERR)
2621         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2622      &   ivec_count(fg_rank1),
2623      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2624      &   FG_COMM1,IERR)
2625         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2626      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2627      &   FG_COMM1,IERR)
2628         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2629      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2630      &   FG_COMM1,IERR)
2631         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2632      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2633      &   FG_COMM1,IERR)
2634         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2635      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2636      &   FG_COMM1,IERR)
2637         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2638      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2639      &   FG_COMM1,IERR)
2640         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2641      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2642      &   FG_COMM1,IERR)
2643         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2644      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2645      &   FG_COMM1,IERR)
2646         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2647      &   ivec_count(fg_rank1),
2648      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2649      &   FG_COMM1,IERR)
2650         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2651      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2652      &   FG_COMM1,IERR)
2653        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2654      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2655      &   FG_COMM1,IERR)
2656         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2657      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2658      &   FG_COMM1,IERR)
2659        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2660      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2661      &   FG_COMM1,IERR)
2662         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2663      &   ivec_count(fg_rank1),
2664      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2665      &   FG_COMM1,IERR)
2666         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2667      &   ivec_count(fg_rank1),
2668      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2669      &   FG_COMM1,IERR)
2670         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2671      &   ivec_count(fg_rank1),
2672      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2673      &   MPI_MAT2,FG_COMM1,IERR)
2674         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2675      &   ivec_count(fg_rank1),
2676      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2677      &   MPI_MAT2,FG_COMM1,IERR)
2678         endif
2679 #else
2680 c Passes matrix info through the ring
2681       isend=fg_rank1
2682       irecv=fg_rank1-1
2683       if (irecv.lt.0) irecv=nfgtasks1-1
2684       iprev=irecv
2685       inext=fg_rank1+1
2686       if (inext.ge.nfgtasks1) inext=0
2687       do i=1,nfgtasks1-1
2688 c        write (iout,*) "isend",isend," irecv",irecv
2689 c        call flush(iout)
2690         lensend=lentyp(isend)
2691         lenrecv=lentyp(irecv)
2692 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2693 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2694 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2695 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2696 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2697 c        write (iout,*) "Gather ROTAT1"
2698 c        call flush(iout)
2699 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2700 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2701 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2702 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2703 c        write (iout,*) "Gather ROTAT2"
2704 c        call flush(iout)
2705         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2706      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2707      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2708      &   iprev,4400+irecv,FG_COMM,status,IERR)
2709 c        write (iout,*) "Gather ROTAT_OLD"
2710 c        call flush(iout)
2711         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2712      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2713      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2714      &   iprev,5500+irecv,FG_COMM,status,IERR)
2715 c        write (iout,*) "Gather PRECOMP11"
2716 c        call flush(iout)
2717         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2718      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2719      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2720      &   iprev,6600+irecv,FG_COMM,status,IERR)
2721 c        write (iout,*) "Gather PRECOMP12"
2722 c        call flush(iout)
2723         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2724      &  then
2725         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2726      &   MPI_ROTAT2(lensend),inext,7700+isend,
2727      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2728      &   iprev,7700+irecv,FG_COMM,status,IERR)
2729 c        write (iout,*) "Gather PRECOMP21"
2730 c        call flush(iout)
2731         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2732      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2733      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2734      &   iprev,8800+irecv,FG_COMM,status,IERR)
2735 c        write (iout,*) "Gather PRECOMP22"
2736 c        call flush(iout)
2737         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2738      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2739      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2740      &   MPI_PRECOMP23(lenrecv),
2741      &   iprev,9900+irecv,FG_COMM,status,IERR)
2742 c        write (iout,*) "Gather PRECOMP23"
2743 c        call flush(iout)
2744         endif
2745         isend=irecv
2746         irecv=irecv-1
2747         if (irecv.lt.0) irecv=nfgtasks1-1
2748       enddo
2749 #endif
2750         time_gather=time_gather+MPI_Wtime()-time00
2751       endif
2752 #ifdef DEBUG
2753 c      if (fg_rank.eq.0) then
2754         write (iout,*) "Arrays UG and UGDER"
2755         do i=1,nres-1
2756           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2757      &     ((ug(l,k,i),l=1,2),k=1,2),
2758      &     ((ugder(l,k,i),l=1,2),k=1,2)
2759         enddo
2760         write (iout,*) "Arrays UG2 and UG2DER"
2761         do i=1,nres-1
2762           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2763      &     ((ug2(l,k,i),l=1,2),k=1,2),
2764      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2765         enddo
2766         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2767         do i=1,nres-1
2768           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2769      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2770      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2771         enddo
2772         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2773         do i=1,nres-1
2774           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2775      &     costab(i),sintab(i),costab2(i),sintab2(i)
2776         enddo
2777         write (iout,*) "Array MUDER"
2778         do i=1,nres-1
2779           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2780         enddo
2781 c      endif
2782 #endif
2783 #endif
2784 cd      do i=1,nres
2785 cd        iti = itortyp(itype(i))
2786 cd        write (iout,*) i
2787 cd        do j=1,2
2788 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2789 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2790 cd        enddo
2791 cd      enddo
2792       return
2793       end
2794 C--------------------------------------------------------------------------
2795       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2796 C
2797 C This subroutine calculates the average interaction energy and its gradient
2798 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2799 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2800 C The potential depends both on the distance of peptide-group centers and on
2801 C the orientation of the CA-CA virtual bonds.
2802 C
2803       implicit real*8 (a-h,o-z)
2804 #ifdef MPI
2805       include 'mpif.h'
2806 #endif
2807       include 'DIMENSIONS'
2808       include 'COMMON.CONTROL'
2809       include 'COMMON.SETUP'
2810       include 'COMMON.IOUNITS'
2811       include 'COMMON.GEO'
2812       include 'COMMON.VAR'
2813       include 'COMMON.LOCAL'
2814       include 'COMMON.CHAIN'
2815       include 'COMMON.DERIV'
2816       include 'COMMON.INTERACT'
2817       include 'COMMON.CONTACTS'
2818       include 'COMMON.TORSION'
2819       include 'COMMON.VECTORS'
2820       include 'COMMON.FFIELD'
2821       include 'COMMON.TIME1'
2822       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2823      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2824       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2825      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2826       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2827      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2828      &    num_conti,j1,j2
2829 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2830 #ifdef MOMENT
2831       double precision scal_el /1.0d0/
2832 #else
2833       double precision scal_el /0.5d0/
2834 #endif
2835 C 12/13/98
2836 C 13-go grudnia roku pamietnego...
2837       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2838      &                   0.0d0,1.0d0,0.0d0,
2839      &                   0.0d0,0.0d0,1.0d0/
2840 cd      write(iout,*) 'In EELEC'
2841 cd      do i=1,nloctyp
2842 cd        write(iout,*) 'Type',i
2843 cd        write(iout,*) 'B1',B1(:,i)
2844 cd        write(iout,*) 'B2',B2(:,i)
2845 cd        write(iout,*) 'CC',CC(:,:,i)
2846 cd        write(iout,*) 'DD',DD(:,:,i)
2847 cd        write(iout,*) 'EE',EE(:,:,i)
2848 cd      enddo
2849 cd      call check_vecgrad
2850 cd      stop
2851       if (icheckgrad.eq.1) then
2852         do i=1,nres-1
2853           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2854           do k=1,3
2855             dc_norm(k,i)=dc(k,i)*fac
2856           enddo
2857 c          write (iout,*) 'i',i,' fac',fac
2858         enddo
2859       endif
2860       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2861      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2862      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2863 c        call vec_and_deriv
2864 #ifdef TIMING
2865         time01=MPI_Wtime()
2866 #endif
2867         call set_matrices
2868 #ifdef TIMING
2869         time_mat=time_mat+MPI_Wtime()-time01
2870 #endif
2871       endif
2872 cd      do i=1,nres-1
2873 cd        write (iout,*) 'i=',i
2874 cd        do k=1,3
2875 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2876 cd        enddo
2877 cd        do k=1,3
2878 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2879 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2880 cd        enddo
2881 cd      enddo
2882       t_eelecij=0.0d0
2883       ees=0.0D0
2884       evdw1=0.0D0
2885       eel_loc=0.0d0
2886       eello_turn3=0.0d0
2887       eello_turn4=0.0d0
2888       ind=0
2889       do i=1,nres
2890         num_cont_hb(i)=0
2891       enddo
2892 cd      print '(a)','Enter EELEC'
2893 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2894       do i=1,nres
2895         gel_loc_loc(i)=0.0d0
2896         gcorr_loc(i)=0.0d0
2897       enddo
2898 c
2899 c
2900 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2901 C
2902 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2903 C
2904       do i=iturn3_start,iturn3_end
2905         dxi=dc(1,i)
2906         dyi=dc(2,i)
2907         dzi=dc(3,i)
2908         dx_normi=dc_norm(1,i)
2909         dy_normi=dc_norm(2,i)
2910         dz_normi=dc_norm(3,i)
2911         xmedi=c(1,i)+0.5d0*dxi
2912         ymedi=c(2,i)+0.5d0*dyi
2913         zmedi=c(3,i)+0.5d0*dzi
2914         num_conti=0
2915         call eelecij(i,i+2,ees,evdw1,eel_loc)
2916         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2917         num_cont_hb(i)=num_conti
2918       enddo
2919       do i=iturn4_start,iturn4_end
2920         dxi=dc(1,i)
2921         dyi=dc(2,i)
2922         dzi=dc(3,i)
2923         dx_normi=dc_norm(1,i)
2924         dy_normi=dc_norm(2,i)
2925         dz_normi=dc_norm(3,i)
2926         xmedi=c(1,i)+0.5d0*dxi
2927         ymedi=c(2,i)+0.5d0*dyi
2928         zmedi=c(3,i)+0.5d0*dzi
2929         num_conti=num_cont_hb(i)
2930         call eelecij(i,i+3,ees,evdw1,eel_loc)
2931         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
2932         num_cont_hb(i)=num_conti
2933       enddo   ! i
2934 c
2935 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2936 c
2937       do i=iatel_s,iatel_e
2938         dxi=dc(1,i)
2939         dyi=dc(2,i)
2940         dzi=dc(3,i)
2941         dx_normi=dc_norm(1,i)
2942         dy_normi=dc_norm(2,i)
2943         dz_normi=dc_norm(3,i)
2944         xmedi=c(1,i)+0.5d0*dxi
2945         ymedi=c(2,i)+0.5d0*dyi
2946         zmedi=c(3,i)+0.5d0*dzi
2947 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2948         num_conti=num_cont_hb(i)
2949         do j=ielstart(i),ielend(i)
2950           call eelecij(i,j,ees,evdw1,eel_loc)
2951         enddo ! j
2952         num_cont_hb(i)=num_conti
2953       enddo   ! i
2954 c      write (iout,*) "Number of loop steps in EELEC:",ind
2955 cd      do i=1,nres
2956 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2957 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2958 cd      enddo
2959 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2960 ccc      eel_loc=eel_loc+eello_turn3
2961 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2962       return
2963       end
2964 C-------------------------------------------------------------------------------
2965       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2966       implicit real*8 (a-h,o-z)
2967       include 'DIMENSIONS'
2968 #ifdef MPI
2969       include "mpif.h"
2970 #endif
2971       include 'COMMON.CONTROL'
2972       include 'COMMON.IOUNITS'
2973       include 'COMMON.GEO'
2974       include 'COMMON.VAR'
2975       include 'COMMON.LOCAL'
2976       include 'COMMON.CHAIN'
2977       include 'COMMON.DERIV'
2978       include 'COMMON.INTERACT'
2979       include 'COMMON.CONTACTS'
2980       include 'COMMON.TORSION'
2981       include 'COMMON.VECTORS'
2982       include 'COMMON.FFIELD'
2983       include 'COMMON.TIME1'
2984       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2985      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2986       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2987      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2988       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2989      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2990      &    num_conti,j1,j2
2991 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2992 #ifdef MOMENT
2993       double precision scal_el /1.0d0/
2994 #else
2995       double precision scal_el /0.5d0/
2996 #endif
2997 C 12/13/98
2998 C 13-go grudnia roku pamietnego...
2999       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3000      &                   0.0d0,1.0d0,0.0d0,
3001      &                   0.0d0,0.0d0,1.0d0/
3002 c          time00=MPI_Wtime()
3003 cd      write (iout,*) "eelecij",i,j
3004 c          ind=ind+1
3005           iteli=itel(i)
3006           itelj=itel(j)
3007           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3008           aaa=app(iteli,itelj)
3009           bbb=bpp(iteli,itelj)
3010           ael6i=ael6(iteli,itelj)
3011           ael3i=ael3(iteli,itelj)
3012           dxj=dc(1,j)
3013           dyj=dc(2,j)
3014           dzj=dc(3,j)
3015           dx_normj=dc_norm(1,j)
3016           dy_normj=dc_norm(2,j)
3017           dz_normj=dc_norm(3,j)
3018           xj=c(1,j)+0.5D0*dxj-xmedi
3019           yj=c(2,j)+0.5D0*dyj-ymedi
3020           zj=c(3,j)+0.5D0*dzj-zmedi
3021           rij=xj*xj+yj*yj+zj*zj
3022           rrmij=1.0D0/rij
3023           rij=dsqrt(rij)
3024           rmij=1.0D0/rij
3025           r3ij=rrmij*rmij
3026           r6ij=r3ij*r3ij
3027           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3028           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3029           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3030           fac=cosa-3.0D0*cosb*cosg
3031           ev1=aaa*r6ij*r6ij
3032 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3033           if (j.eq.i+2) ev1=scal_el*ev1
3034           ev2=bbb*r6ij
3035           fac3=ael6i*r6ij
3036           fac4=ael3i*r3ij
3037           evdwij=ev1+ev2
3038           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3039           el2=fac4*fac
3040           eesij=el1+el2
3041 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3042           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3043           ees=ees+eesij
3044           evdw1=evdw1+evdwij
3045 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3046 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3047 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3048 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3049
3050           if (energy_dec) then
3051               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3052               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3053           endif
3054
3055 C
3056 C Calculate contributions to the Cartesian gradient.
3057 C
3058 #ifdef SPLITELE
3059           facvdw=-6*rrmij*(ev1+evdwij)
3060           facel=-3*rrmij*(el1+eesij)
3061           fac1=fac
3062           erij(1)=xj*rmij
3063           erij(2)=yj*rmij
3064           erij(3)=zj*rmij
3065 *
3066 * Radial derivatives. First process both termini of the fragment (i,j)
3067 *
3068           ggg(1)=facel*xj
3069           ggg(2)=facel*yj
3070           ggg(3)=facel*zj
3071 c          do k=1,3
3072 c            ghalf=0.5D0*ggg(k)
3073 c            gelc(k,i)=gelc(k,i)+ghalf
3074 c            gelc(k,j)=gelc(k,j)+ghalf
3075 c          enddo
3076 c 9/28/08 AL Gradient compotents will be summed only at the end
3077           do k=1,3
3078             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3079             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3080           enddo
3081 *
3082 * Loop over residues i+1 thru j-1.
3083 *
3084 cgrad          do k=i+1,j-1
3085 cgrad            do l=1,3
3086 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3087 cgrad            enddo
3088 cgrad          enddo
3089           ggg(1)=facvdw*xj
3090           ggg(2)=facvdw*yj
3091           ggg(3)=facvdw*zj
3092 c          do k=1,3
3093 c            ghalf=0.5D0*ggg(k)
3094 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3095 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3096 c          enddo
3097 c 9/28/08 AL Gradient compotents will be summed only at the end
3098           do k=1,3
3099             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3100             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3101           enddo
3102 *
3103 * Loop over residues i+1 thru j-1.
3104 *
3105 cgrad          do k=i+1,j-1
3106 cgrad            do l=1,3
3107 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3108 cgrad            enddo
3109 cgrad          enddo
3110 #else
3111           facvdw=ev1+evdwij
3112           facel=el1+eesij
3113           fac1=fac
3114           fac=-3*rrmij*(facvdw+facvdw+facel)
3115           erij(1)=xj*rmij
3116           erij(2)=yj*rmij
3117           erij(3)=zj*rmij
3118 *
3119 * Radial derivatives. First process both termini of the fragment (i,j)
3120 *
3121           ggg(1)=fac*xj
3122           ggg(2)=fac*yj
3123           ggg(3)=fac*zj
3124 c          do k=1,3
3125 c            ghalf=0.5D0*ggg(k)
3126 c            gelc(k,i)=gelc(k,i)+ghalf
3127 c            gelc(k,j)=gelc(k,j)+ghalf
3128 c          enddo
3129 c 9/28/08 AL Gradient compotents will be summed only at the end
3130           do k=1,3
3131             gelc_long(k,j)=gelc(k,j)+ggg(k)
3132             gelc_long(k,i)=gelc(k,i)-ggg(k)
3133           enddo
3134 *
3135 * Loop over residues i+1 thru j-1.
3136 *
3137 cgrad          do k=i+1,j-1
3138 cgrad            do l=1,3
3139 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3140 cgrad            enddo
3141 cgrad          enddo
3142 c 9/28/08 AL Gradient compotents will be summed only at the end
3143           ggg(1)=facvdw*xj
3144           ggg(2)=facvdw*yj
3145           ggg(3)=facvdw*zj
3146           do k=1,3
3147             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3148             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3149           enddo
3150 #endif
3151 *
3152 * Angular part
3153 *
3154           ecosa=2.0D0*fac3*fac1+fac4
3155           fac4=-3.0D0*fac4
3156           fac3=-6.0D0*fac3
3157           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3158           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3159           do k=1,3
3160             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3161             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3162           enddo
3163 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3164 cd   &          (dcosg(k),k=1,3)
3165           do k=1,3
3166             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3167           enddo
3168 c          do k=1,3
3169 c            ghalf=0.5D0*ggg(k)
3170 c            gelc(k,i)=gelc(k,i)+ghalf
3171 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3172 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3173 c            gelc(k,j)=gelc(k,j)+ghalf
3174 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3175 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3176 c          enddo
3177 cgrad          do k=i+1,j-1
3178 cgrad            do l=1,3
3179 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3180 cgrad            enddo
3181 cgrad          enddo
3182           do k=1,3
3183             gelc(k,i)=gelc(k,i)
3184      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3185      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3186             gelc(k,j)=gelc(k,j)
3187      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3188      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3189             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3190             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3191           enddo
3192           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3193      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3194      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3195 C
3196 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3197 C   energy of a peptide unit is assumed in the form of a second-order
3198 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3199 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3200 C   are computed for EVERY pair of non-contiguous peptide groups.
3201 C
3202           if (j.lt.nres-1) then
3203             j1=j+1
3204             j2=j-1
3205           else
3206             j1=j-1
3207             j2=j-2
3208           endif
3209           kkk=0
3210           do k=1,2
3211             do l=1,2
3212               kkk=kkk+1
3213               muij(kkk)=mu(k,i)*mu(l,j)
3214             enddo
3215           enddo
3216 cd         write (iout,*) 'EELEC: i',i,' j',j
3217 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3218 cd          write(iout,*) 'muij',muij
3219           ury=scalar(uy(1,i),erij)
3220           urz=scalar(uz(1,i),erij)
3221           vry=scalar(uy(1,j),erij)
3222           vrz=scalar(uz(1,j),erij)
3223           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3224           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3225           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3226           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3227           fac=dsqrt(-ael6i)*r3ij
3228           a22=a22*fac
3229           a23=a23*fac
3230           a32=a32*fac
3231           a33=a33*fac
3232 cd          write (iout,'(4i5,4f10.5)')
3233 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3234 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3235 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3236 cd     &      uy(:,j),uz(:,j)
3237 cd          write (iout,'(4f10.5)')
3238 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3239 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3240 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3241 cd           write (iout,'(9f10.5/)')
3242 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3243 C Derivatives of the elements of A in virtual-bond vectors
3244           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3245           do k=1,3
3246             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3247             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3248             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3249             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3250             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3251             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3252             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3253             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3254             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3255             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3256             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3257             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3258           enddo
3259 C Compute radial contributions to the gradient
3260           facr=-3.0d0*rrmij
3261           a22der=a22*facr
3262           a23der=a23*facr
3263           a32der=a32*facr
3264           a33der=a33*facr
3265           agg(1,1)=a22der*xj
3266           agg(2,1)=a22der*yj
3267           agg(3,1)=a22der*zj
3268           agg(1,2)=a23der*xj
3269           agg(2,2)=a23der*yj
3270           agg(3,2)=a23der*zj
3271           agg(1,3)=a32der*xj
3272           agg(2,3)=a32der*yj
3273           agg(3,3)=a32der*zj
3274           agg(1,4)=a33der*xj
3275           agg(2,4)=a33der*yj
3276           agg(3,4)=a33der*zj
3277 C Add the contributions coming from er
3278           fac3=-3.0d0*fac
3279           do k=1,3
3280             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3281             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3282             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3283             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3284           enddo
3285           do k=1,3
3286 C Derivatives in DC(i)
3287 cgrad            ghalf1=0.5d0*agg(k,1)
3288 cgrad            ghalf2=0.5d0*agg(k,2)
3289 cgrad            ghalf3=0.5d0*agg(k,3)
3290 cgrad            ghalf4=0.5d0*agg(k,4)
3291             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3292      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3293             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3294      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3295             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3296      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3297             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3298      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3299 C Derivatives in DC(i+1)
3300             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3301      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3302             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3303      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3304             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3305      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3306             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3307      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3308 C Derivatives in DC(j)
3309             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3310      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3311             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3312      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3313             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3314      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3315             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3316      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3317 C Derivatives in DC(j+1) or DC(nres-1)
3318             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3319      &      -3.0d0*vryg(k,3)*ury)
3320             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3321      &      -3.0d0*vrzg(k,3)*ury)
3322             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3323      &      -3.0d0*vryg(k,3)*urz)
3324             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3325      &      -3.0d0*vrzg(k,3)*urz)
3326 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3327 cgrad              do l=1,4
3328 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3329 cgrad              enddo
3330 cgrad            endif
3331           enddo
3332           acipa(1,1)=a22
3333           acipa(1,2)=a23
3334           acipa(2,1)=a32
3335           acipa(2,2)=a33
3336           a22=-a22
3337           a23=-a23
3338           do l=1,2
3339             do k=1,3
3340               agg(k,l)=-agg(k,l)
3341               aggi(k,l)=-aggi(k,l)
3342               aggi1(k,l)=-aggi1(k,l)
3343               aggj(k,l)=-aggj(k,l)
3344               aggj1(k,l)=-aggj1(k,l)
3345             enddo
3346           enddo
3347           if (j.lt.nres-1) then
3348             a22=-a22
3349             a32=-a32
3350             do l=1,3,2
3351               do k=1,3
3352                 agg(k,l)=-agg(k,l)
3353                 aggi(k,l)=-aggi(k,l)
3354                 aggi1(k,l)=-aggi1(k,l)
3355                 aggj(k,l)=-aggj(k,l)
3356                 aggj1(k,l)=-aggj1(k,l)
3357               enddo
3358             enddo
3359           else
3360             a22=-a22
3361             a23=-a23
3362             a32=-a32
3363             a33=-a33
3364             do l=1,4
3365               do k=1,3
3366                 agg(k,l)=-agg(k,l)
3367                 aggi(k,l)=-aggi(k,l)
3368                 aggi1(k,l)=-aggi1(k,l)
3369                 aggj(k,l)=-aggj(k,l)
3370                 aggj1(k,l)=-aggj1(k,l)
3371               enddo
3372             enddo
3373           endif
3374           ENDIF ! WCORR
3375           IF (wel_loc.gt.0.0d0) THEN
3376 C Contribution to the local-electrostatic energy coming from the i-j pair
3377           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3378      &     +a33*muij(4)
3379 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3380
3381           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3382      &            'eelloc',i,j,eel_loc_ij
3383
3384           eel_loc=eel_loc+eel_loc_ij
3385 C Partial derivatives in virtual-bond dihedral angles gamma
3386           if (i.gt.1)
3387      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3388      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3389      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3390           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3391      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3392      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3393 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3394           do l=1,3
3395             ggg(l)=agg(l,1)*muij(1)+
3396      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3397             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3398             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3399 cgrad            ghalf=0.5d0*ggg(l)
3400 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3401 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3402           enddo
3403 cgrad          do k=i+1,j2
3404 cgrad            do l=1,3
3405 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3406 cgrad            enddo
3407 cgrad          enddo
3408 C Remaining derivatives of eello
3409           do l=1,3
3410             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3411      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3412             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3413      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3414             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3415      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3416             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3417      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3418           enddo
3419           ENDIF
3420 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3421 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3422           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3423      &       .and. num_conti.le.maxconts) then
3424 c            write (iout,*) i,j," entered corr"
3425 C
3426 C Calculate the contact function. The ith column of the array JCONT will
3427 C contain the numbers of atoms that make contacts with the atom I (of numbers
3428 C greater than I). The arrays FACONT and GACONT will contain the values of
3429 C the contact function and its derivative.
3430 c           r0ij=1.02D0*rpp(iteli,itelj)
3431 c           r0ij=1.11D0*rpp(iteli,itelj)
3432             r0ij=2.20D0*rpp(iteli,itelj)
3433 c           r0ij=1.55D0*rpp(iteli,itelj)
3434             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3435             if (fcont.gt.0.0D0) then
3436               num_conti=num_conti+1
3437               if (num_conti.gt.maxconts) then
3438                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3439      &                         ' will skip next contacts for this conf.'
3440               else
3441                 jcont_hb(num_conti,i)=j
3442 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3443 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3444                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3445      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3446 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3447 C  terms.
3448                 d_cont(num_conti,i)=rij
3449 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3450 C     --- Electrostatic-interaction matrix ---
3451                 a_chuj(1,1,num_conti,i)=a22
3452                 a_chuj(1,2,num_conti,i)=a23
3453                 a_chuj(2,1,num_conti,i)=a32
3454                 a_chuj(2,2,num_conti,i)=a33
3455 C     --- Gradient of rij
3456                 do kkk=1,3
3457                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3458                 enddo
3459                 kkll=0
3460                 do k=1,2
3461                   do l=1,2
3462                     kkll=kkll+1
3463                     do m=1,3
3464                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3465                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3466                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3467                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3468                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3469                     enddo
3470                   enddo
3471                 enddo
3472                 ENDIF
3473                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3474 C Calculate contact energies
3475                 cosa4=4.0D0*cosa
3476                 wij=cosa-3.0D0*cosb*cosg
3477                 cosbg1=cosb+cosg
3478                 cosbg2=cosb-cosg
3479 c               fac3=dsqrt(-ael6i)/r0ij**3
3480                 fac3=dsqrt(-ael6i)*r3ij
3481 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3482                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3483                 if (ees0tmp.gt.0) then
3484                   ees0pij=dsqrt(ees0tmp)
3485                 else
3486                   ees0pij=0
3487                 endif
3488 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3489                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3490                 if (ees0tmp.gt.0) then
3491                   ees0mij=dsqrt(ees0tmp)
3492                 else
3493                   ees0mij=0
3494                 endif
3495 c               ees0mij=0.0D0
3496                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3497                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3498 C Diagnostics. Comment out or remove after debugging!
3499 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3500 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3501 c               ees0m(num_conti,i)=0.0D0
3502 C End diagnostics.
3503 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3504 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3505 C Angular derivatives of the contact function
3506                 ees0pij1=fac3/ees0pij
3507                 ees0mij1=fac3/ees0mij
3508                 fac3p=-3.0D0*fac3*rrmij
3509                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3510                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3511 c               ees0mij1=0.0D0
3512                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3513                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3514                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3515                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3516                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3517                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3518                 ecosap=ecosa1+ecosa2
3519                 ecosbp=ecosb1+ecosb2
3520                 ecosgp=ecosg1+ecosg2
3521                 ecosam=ecosa1-ecosa2
3522                 ecosbm=ecosb1-ecosb2
3523                 ecosgm=ecosg1-ecosg2
3524 C Diagnostics
3525 c               ecosap=ecosa1
3526 c               ecosbp=ecosb1
3527 c               ecosgp=ecosg1
3528 c               ecosam=0.0D0
3529 c               ecosbm=0.0D0
3530 c               ecosgm=0.0D0
3531 C End diagnostics
3532                 facont_hb(num_conti,i)=fcont
3533                 fprimcont=fprimcont/rij
3534 cd              facont_hb(num_conti,i)=1.0D0
3535 C Following line is for diagnostics.
3536 cd              fprimcont=0.0D0
3537                 do k=1,3
3538                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3539                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3540                 enddo
3541                 do k=1,3
3542                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3543                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3544                 enddo
3545                 gggp(1)=gggp(1)+ees0pijp*xj
3546                 gggp(2)=gggp(2)+ees0pijp*yj
3547                 gggp(3)=gggp(3)+ees0pijp*zj
3548                 gggm(1)=gggm(1)+ees0mijp*xj
3549                 gggm(2)=gggm(2)+ees0mijp*yj
3550                 gggm(3)=gggm(3)+ees0mijp*zj
3551 C Derivatives due to the contact function
3552                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3553                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3554                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3555                 do k=1,3
3556 c
3557 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3558 c          following the change of gradient-summation algorithm.
3559 c
3560 cgrad                  ghalfp=0.5D0*gggp(k)
3561 cgrad                  ghalfm=0.5D0*gggm(k)
3562                   gacontp_hb1(k,num_conti,i)=!ghalfp
3563      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3564      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3565                   gacontp_hb2(k,num_conti,i)=!ghalfp
3566      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3567      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3568                   gacontp_hb3(k,num_conti,i)=gggp(k)
3569                   gacontm_hb1(k,num_conti,i)=!ghalfm
3570      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3571      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3572                   gacontm_hb2(k,num_conti,i)=!ghalfm
3573      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3574      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3575                   gacontm_hb3(k,num_conti,i)=gggm(k)
3576                 enddo
3577 C Diagnostics. Comment out or remove after debugging!
3578 cdiag           do k=1,3
3579 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3580 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3581 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3582 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3583 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3584 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3585 cdiag           enddo
3586               ENDIF ! wcorr
3587               endif  ! num_conti.le.maxconts
3588             endif  ! fcont.gt.0
3589           endif    ! j.gt.i+1
3590           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3591             do k=1,4
3592               do l=1,3
3593                 ghalf=0.5d0*agg(l,k)
3594                 aggi(l,k)=aggi(l,k)+ghalf
3595                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3596                 aggj(l,k)=aggj(l,k)+ghalf
3597               enddo
3598             enddo
3599             if (j.eq.nres-1 .and. i.lt.j-2) then
3600               do k=1,4
3601                 do l=1,3
3602                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3603                 enddo
3604               enddo
3605             endif
3606           endif
3607 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3608       return
3609       end
3610 C-----------------------------------------------------------------------------
3611       subroutine eturn3(i,eello_turn3)
3612 C Third- and fourth-order contributions from turns
3613       implicit real*8 (a-h,o-z)
3614       include 'DIMENSIONS'
3615       include 'COMMON.IOUNITS'
3616       include 'COMMON.GEO'
3617       include 'COMMON.VAR'
3618       include 'COMMON.LOCAL'
3619       include 'COMMON.CHAIN'
3620       include 'COMMON.DERIV'
3621       include 'COMMON.INTERACT'
3622       include 'COMMON.CONTACTS'
3623       include 'COMMON.TORSION'
3624       include 'COMMON.VECTORS'
3625       include 'COMMON.FFIELD'
3626       include 'COMMON.CONTROL'
3627       dimension ggg(3)
3628       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3629      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3630      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3631       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3632      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3633       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3634      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3635      &    num_conti,j1,j2
3636       j=i+2
3637 c      write (iout,*) "eturn3",i,j,j1,j2
3638       a_temp(1,1)=a22
3639       a_temp(1,2)=a23
3640       a_temp(2,1)=a32
3641       a_temp(2,2)=a33
3642 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3643 C
3644 C               Third-order contributions
3645 C
3646 C                 (i+2)o----(i+3)
3647 C                      | |
3648 C                      | |
3649 C                 (i+1)o----i
3650 C
3651 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3652 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3653         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3654         call transpose2(auxmat(1,1),auxmat1(1,1))
3655         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3656         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3657         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3658      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3659 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3660 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3661 cd     &    ' eello_turn3_num',4*eello_turn3_num
3662 C Derivatives in gamma(i)
3663         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3664         call transpose2(auxmat2(1,1),auxmat3(1,1))
3665         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3666         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3667 C Derivatives in gamma(i+1)
3668         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3669         call transpose2(auxmat2(1,1),auxmat3(1,1))
3670         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3671         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3672      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3673 C Cartesian derivatives
3674         do l=1,3
3675 c            ghalf1=0.5d0*agg(l,1)
3676 c            ghalf2=0.5d0*agg(l,2)
3677 c            ghalf3=0.5d0*agg(l,3)
3678 c            ghalf4=0.5d0*agg(l,4)
3679           a_temp(1,1)=aggi(l,1)!+ghalf1
3680           a_temp(1,2)=aggi(l,2)!+ghalf2
3681           a_temp(2,1)=aggi(l,3)!+ghalf3
3682           a_temp(2,2)=aggi(l,4)!+ghalf4
3683           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3684           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3685      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3686           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3687           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3688           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3689           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3690           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3691           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3692      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3693           a_temp(1,1)=aggj(l,1)!+ghalf1
3694           a_temp(1,2)=aggj(l,2)!+ghalf2
3695           a_temp(2,1)=aggj(l,3)!+ghalf3
3696           a_temp(2,2)=aggj(l,4)!+ghalf4
3697           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3698           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3699      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3700           a_temp(1,1)=aggj1(l,1)
3701           a_temp(1,2)=aggj1(l,2)
3702           a_temp(2,1)=aggj1(l,3)
3703           a_temp(2,2)=aggj1(l,4)
3704           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3705           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3706      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3707         enddo
3708       return
3709       end
3710 C-------------------------------------------------------------------------------
3711       subroutine eturn4(i,eello_turn4)
3712 C Third- and fourth-order contributions from turns
3713       implicit real*8 (a-h,o-z)
3714       include 'DIMENSIONS'
3715       include 'COMMON.IOUNITS'
3716       include 'COMMON.GEO'
3717       include 'COMMON.VAR'
3718       include 'COMMON.LOCAL'
3719       include 'COMMON.CHAIN'
3720       include 'COMMON.DERIV'
3721       include 'COMMON.INTERACT'
3722       include 'COMMON.CONTACTS'
3723       include 'COMMON.TORSION'
3724       include 'COMMON.VECTORS'
3725       include 'COMMON.FFIELD'
3726       include 'COMMON.CONTROL'
3727       dimension ggg(3)
3728       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3729      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3730      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3731       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3732      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3733       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3734      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3735      &    num_conti,j1,j2
3736       j=i+3
3737 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3738 C
3739 C               Fourth-order contributions
3740 C
3741 C                 (i+3)o----(i+4)
3742 C                     /  |
3743 C               (i+2)o   |
3744 C                     \  |
3745 C                 (i+1)o----i
3746 C
3747 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3748 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3749 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3750         a_temp(1,1)=a22
3751         a_temp(1,2)=a23
3752         a_temp(2,1)=a32
3753         a_temp(2,2)=a33
3754         iti1=itortyp(itype(i+1))
3755         iti2=itortyp(itype(i+2))
3756         iti3=itortyp(itype(i+3))
3757 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3758         call transpose2(EUg(1,1,i+1),e1t(1,1))
3759         call transpose2(Eug(1,1,i+2),e2t(1,1))
3760         call transpose2(Eug(1,1,i+3),e3t(1,1))
3761         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3762         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3763         s1=scalar2(b1(1,iti2),auxvec(1))
3764         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3765         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3766         s2=scalar2(b1(1,iti1),auxvec(1))
3767         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3768         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3769         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3770         eello_turn4=eello_turn4-(s1+s2+s3)
3771         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3772      &      'eturn4',i,j,-(s1+s2+s3)
3773 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3774 cd     &    ' eello_turn4_num',8*eello_turn4_num
3775 C Derivatives in gamma(i)
3776         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3777         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3778         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3779         s1=scalar2(b1(1,iti2),auxvec(1))
3780         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3781         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3782         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3783 C Derivatives in gamma(i+1)
3784         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3785         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3786         s2=scalar2(b1(1,iti1),auxvec(1))
3787         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3788         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3789         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3790         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3791 C Derivatives in gamma(i+2)
3792         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3793         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3794         s1=scalar2(b1(1,iti2),auxvec(1))
3795         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3796         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3797         s2=scalar2(b1(1,iti1),auxvec(1))
3798         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3799         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3800         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3801         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3802 C Cartesian derivatives
3803 C Derivatives of this turn contributions in DC(i+2)
3804         if (j.lt.nres-1) then
3805           do l=1,3
3806             a_temp(1,1)=agg(l,1)
3807             a_temp(1,2)=agg(l,2)
3808             a_temp(2,1)=agg(l,3)
3809             a_temp(2,2)=agg(l,4)
3810             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3811             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3812             s1=scalar2(b1(1,iti2),auxvec(1))
3813             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3814             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3815             s2=scalar2(b1(1,iti1),auxvec(1))
3816             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3817             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3818             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3819             ggg(l)=-(s1+s2+s3)
3820             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3821           enddo
3822         endif
3823 C Remaining derivatives of this turn contribution
3824         do l=1,3
3825           a_temp(1,1)=aggi(l,1)
3826           a_temp(1,2)=aggi(l,2)
3827           a_temp(2,1)=aggi(l,3)
3828           a_temp(2,2)=aggi(l,4)
3829           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3830           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3831           s1=scalar2(b1(1,iti2),auxvec(1))
3832           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3833           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3834           s2=scalar2(b1(1,iti1),auxvec(1))
3835           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3836           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3837           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3838           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3839           a_temp(1,1)=aggi1(l,1)
3840           a_temp(1,2)=aggi1(l,2)
3841           a_temp(2,1)=aggi1(l,3)
3842           a_temp(2,2)=aggi1(l,4)
3843           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3844           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3845           s1=scalar2(b1(1,iti2),auxvec(1))
3846           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3847           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3848           s2=scalar2(b1(1,iti1),auxvec(1))
3849           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3850           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3851           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3852           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3853           a_temp(1,1)=aggj(l,1)
3854           a_temp(1,2)=aggj(l,2)
3855           a_temp(2,1)=aggj(l,3)
3856           a_temp(2,2)=aggj(l,4)
3857           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3858           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3859           s1=scalar2(b1(1,iti2),auxvec(1))
3860           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3861           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3862           s2=scalar2(b1(1,iti1),auxvec(1))
3863           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3864           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3865           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3866           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3867           a_temp(1,1)=aggj1(l,1)
3868           a_temp(1,2)=aggj1(l,2)
3869           a_temp(2,1)=aggj1(l,3)
3870           a_temp(2,2)=aggj1(l,4)
3871           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3872           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3873           s1=scalar2(b1(1,iti2),auxvec(1))
3874           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3875           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3876           s2=scalar2(b1(1,iti1),auxvec(1))
3877           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3878           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3879           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3880 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3881           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3882         enddo
3883       return
3884       end
3885 C-----------------------------------------------------------------------------
3886       subroutine vecpr(u,v,w)
3887       implicit real*8(a-h,o-z)
3888       dimension u(3),v(3),w(3)
3889       w(1)=u(2)*v(3)-u(3)*v(2)
3890       w(2)=-u(1)*v(3)+u(3)*v(1)
3891       w(3)=u(1)*v(2)-u(2)*v(1)
3892       return
3893       end
3894 C-----------------------------------------------------------------------------
3895       subroutine unormderiv(u,ugrad,unorm,ungrad)
3896 C This subroutine computes the derivatives of a normalized vector u, given
3897 C the derivatives computed without normalization conditions, ugrad. Returns
3898 C ungrad.
3899       implicit none
3900       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3901       double precision vec(3)
3902       double precision scalar
3903       integer i,j
3904 c      write (2,*) 'ugrad',ugrad
3905 c      write (2,*) 'u',u
3906       do i=1,3
3907         vec(i)=scalar(ugrad(1,i),u(1))
3908       enddo
3909 c      write (2,*) 'vec',vec
3910       do i=1,3
3911         do j=1,3
3912           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3913         enddo
3914       enddo
3915 c      write (2,*) 'ungrad',ungrad
3916       return
3917       end
3918 C-----------------------------------------------------------------------------
3919       subroutine escp_soft_sphere(evdw2,evdw2_14)
3920 C
3921 C This subroutine calculates the excluded-volume interaction energy between
3922 C peptide-group centers and side chains and its gradient in virtual-bond and
3923 C side-chain vectors.
3924 C
3925       implicit real*8 (a-h,o-z)
3926       include 'DIMENSIONS'
3927       include 'COMMON.GEO'
3928       include 'COMMON.VAR'
3929       include 'COMMON.LOCAL'
3930       include 'COMMON.CHAIN'
3931       include 'COMMON.DERIV'
3932       include 'COMMON.INTERACT'
3933       include 'COMMON.FFIELD'
3934       include 'COMMON.IOUNITS'
3935       include 'COMMON.CONTROL'
3936       dimension ggg(3)
3937       evdw2=0.0D0
3938       evdw2_14=0.0d0
3939       r0_scp=4.5d0
3940 cd    print '(a)','Enter ESCP'
3941 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3942       do i=iatscp_s,iatscp_e
3943         iteli=itel(i)
3944         xi=0.5D0*(c(1,i)+c(1,i+1))
3945         yi=0.5D0*(c(2,i)+c(2,i+1))
3946         zi=0.5D0*(c(3,i)+c(3,i+1))
3947
3948         do iint=1,nscp_gr(i)
3949
3950         do j=iscpstart(i,iint),iscpend(i,iint)
3951           itypj=itype(j)
3952 C Uncomment following three lines for SC-p interactions
3953 c         xj=c(1,nres+j)-xi
3954 c         yj=c(2,nres+j)-yi
3955 c         zj=c(3,nres+j)-zi
3956 C Uncomment following three lines for Ca-p interactions
3957           xj=c(1,j)-xi
3958           yj=c(2,j)-yi
3959           zj=c(3,j)-zi
3960           rij=xj*xj+yj*yj+zj*zj
3961           r0ij=r0_scp
3962           r0ijsq=r0ij*r0ij
3963           if (rij.lt.r0ijsq) then
3964             evdwij=0.25d0*(rij-r0ijsq)**2
3965             fac=rij-r0ijsq
3966           else
3967             evdwij=0.0d0
3968             fac=0.0d0
3969           endif
3970           evdw2=evdw2+evdwij
3971 C
3972 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3973 C
3974           ggg(1)=xj*fac
3975           ggg(2)=yj*fac
3976           ggg(3)=zj*fac
3977 cgrad          if (j.lt.i) then
3978 cd          write (iout,*) 'j<i'
3979 C Uncomment following three lines for SC-p interactions
3980 c           do k=1,3
3981 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3982 c           enddo
3983 cgrad          else
3984 cd          write (iout,*) 'j>i'
3985 cgrad            do k=1,3
3986 cgrad              ggg(k)=-ggg(k)
3987 C Uncomment following line for SC-p interactions
3988 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3989 cgrad            enddo
3990 cgrad          endif
3991 cgrad          do k=1,3
3992 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3993 cgrad          enddo
3994 cgrad          kstart=min0(i+1,j)
3995 cgrad          kend=max0(i-1,j-1)
3996 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3997 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3998 cgrad          do k=kstart,kend
3999 cgrad            do l=1,3
4000 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4001 cgrad            enddo
4002 cgrad          enddo
4003           do k=1,3
4004             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4005             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4006           enddo
4007         enddo
4008
4009         enddo ! iint
4010       enddo ! i
4011       return
4012       end
4013 C-----------------------------------------------------------------------------
4014       subroutine escp(evdw2,evdw2_14)
4015 C
4016 C This subroutine calculates the excluded-volume interaction energy between
4017 C peptide-group centers and side chains and its gradient in virtual-bond and
4018 C side-chain vectors.
4019 C
4020       implicit real*8 (a-h,o-z)
4021       include 'DIMENSIONS'
4022       include 'COMMON.GEO'
4023       include 'COMMON.VAR'
4024       include 'COMMON.LOCAL'
4025       include 'COMMON.CHAIN'
4026       include 'COMMON.DERIV'
4027       include 'COMMON.INTERACT'
4028       include 'COMMON.FFIELD'
4029       include 'COMMON.IOUNITS'
4030       include 'COMMON.CONTROL'
4031       dimension ggg(3)
4032       evdw2=0.0D0
4033       evdw2_14=0.0d0
4034 cd    print '(a)','Enter ESCP'
4035 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4036       do i=iatscp_s,iatscp_e
4037         iteli=itel(i)
4038         xi=0.5D0*(c(1,i)+c(1,i+1))
4039         yi=0.5D0*(c(2,i)+c(2,i+1))
4040         zi=0.5D0*(c(3,i)+c(3,i+1))
4041
4042         do iint=1,nscp_gr(i)
4043
4044         do j=iscpstart(i,iint),iscpend(i,iint)
4045           itypj=itype(j)
4046 C Uncomment following three lines for SC-p interactions
4047 c         xj=c(1,nres+j)-xi
4048 c         yj=c(2,nres+j)-yi
4049 c         zj=c(3,nres+j)-zi
4050 C Uncomment following three lines for Ca-p interactions
4051           xj=c(1,j)-xi
4052           yj=c(2,j)-yi
4053           zj=c(3,j)-zi
4054           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4055           fac=rrij**expon2
4056           e1=fac*fac*aad(itypj,iteli)
4057           e2=fac*bad(itypj,iteli)
4058           if (iabs(j-i) .le. 2) then
4059             e1=scal14*e1
4060             e2=scal14*e2
4061             evdw2_14=evdw2_14+e1+e2
4062           endif
4063           evdwij=e1+e2
4064           evdw2=evdw2+evdwij
4065           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4066      &        'evdw2',i,j,evdwij
4067 C
4068 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4069 C
4070           fac=-(evdwij+e1)*rrij
4071           ggg(1)=xj*fac
4072           ggg(2)=yj*fac
4073           ggg(3)=zj*fac
4074 cgrad          if (j.lt.i) then
4075 cd          write (iout,*) 'j<i'
4076 C Uncomment following three lines for SC-p interactions
4077 c           do k=1,3
4078 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4079 c           enddo
4080 cgrad          else
4081 cd          write (iout,*) 'j>i'
4082 cgrad            do k=1,3
4083 cgrad              ggg(k)=-ggg(k)
4084 C Uncomment following line for SC-p interactions
4085 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4086 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4087 cgrad            enddo
4088 cgrad          endif
4089 cgrad          do k=1,3
4090 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4091 cgrad          enddo
4092 cgrad          kstart=min0(i+1,j)
4093 cgrad          kend=max0(i-1,j-1)
4094 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4095 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4096 cgrad          do k=kstart,kend
4097 cgrad            do l=1,3
4098 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4099 cgrad            enddo
4100 cgrad          enddo
4101           do k=1,3
4102             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4103             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4104           enddo
4105         enddo
4106
4107         enddo ! iint
4108       enddo ! i
4109       do i=1,nct
4110         do j=1,3
4111           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4112           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4113           gradx_scp(j,i)=expon*gradx_scp(j,i)
4114         enddo
4115       enddo
4116 C******************************************************************************
4117 C
4118 C                              N O T E !!!
4119 C
4120 C To save time the factor EXPON has been extracted from ALL components
4121 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4122 C use!
4123 C
4124 C******************************************************************************
4125       return
4126       end
4127 C--------------------------------------------------------------------------
4128       subroutine edis(ehpb)
4129 C
4130 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4131 C
4132       implicit real*8 (a-h,o-z)
4133       include 'DIMENSIONS'
4134       include 'COMMON.SBRIDGE'
4135       include 'COMMON.CHAIN'
4136       include 'COMMON.DERIV'
4137       include 'COMMON.VAR'
4138       include 'COMMON.INTERACT'
4139       include 'COMMON.IOUNITS'
4140       dimension ggg(3)
4141       ehpb=0.0D0
4142 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4143 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4144       if (link_end.eq.0) return
4145       do i=link_start,link_end
4146 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4147 C CA-CA distance used in regularization of structure.
4148         ii=ihpb(i)
4149         jj=jhpb(i)
4150 C iii and jjj point to the residues for which the distance is assigned.
4151         if (ii.gt.nres) then
4152           iii=ii-nres
4153           jjj=jj-nres
4154         else
4155           iii=ii
4156           jjj=jj
4157         endif
4158 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4159 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4160 C    distance and angle dependent SS bond potential.
4161         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4162           call ssbond_ene(iii,jjj,eij)
4163           ehpb=ehpb+2*eij
4164 cd          write (iout,*) "eij",eij
4165         else
4166 C Calculate the distance between the two points and its difference from the
4167 C target distance.
4168         dd=dist(ii,jj)
4169         rdis=dd-dhpb(i)
4170 C Get the force constant corresponding to this distance.
4171         waga=forcon(i)
4172 C Calculate the contribution to energy.
4173         ehpb=ehpb+waga*rdis*rdis
4174 C
4175 C Evaluate gradient.
4176 C
4177         fac=waga*rdis/dd
4178 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4179 cd   &   ' waga=',waga,' fac=',fac
4180         do j=1,3
4181           ggg(j)=fac*(c(j,jj)-c(j,ii))
4182         enddo
4183 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4184 C If this is a SC-SC distance, we need to calculate the contributions to the
4185 C Cartesian gradient in the SC vectors (ghpbx).
4186         if (iii.lt.ii) then
4187           do j=1,3
4188             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4189             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4190           enddo
4191         endif
4192 cgrad        do j=iii,jjj-1
4193 cgrad          do k=1,3
4194 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4195 cgrad          enddo
4196 cgrad        enddo
4197         do k=1,3
4198           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4199           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4200         enddo
4201         endif
4202       enddo
4203       ehpb=0.5D0*ehpb
4204       return
4205       end
4206 C--------------------------------------------------------------------------
4207       subroutine ssbond_ene(i,j,eij)
4208 C
4209 C Calculate the distance and angle dependent SS-bond potential energy
4210 C using a free-energy function derived based on RHF/6-31G** ab initio
4211 C calculations of diethyl disulfide.
4212 C
4213 C A. Liwo and U. Kozlowska, 11/24/03
4214 C
4215       implicit real*8 (a-h,o-z)
4216       include 'DIMENSIONS'
4217       include 'COMMON.SBRIDGE'
4218       include 'COMMON.CHAIN'
4219       include 'COMMON.DERIV'
4220       include 'COMMON.LOCAL'
4221       include 'COMMON.INTERACT'
4222       include 'COMMON.VAR'
4223       include 'COMMON.IOUNITS'
4224       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4225       itypi=itype(i)
4226       xi=c(1,nres+i)
4227       yi=c(2,nres+i)
4228       zi=c(3,nres+i)
4229       dxi=dc_norm(1,nres+i)
4230       dyi=dc_norm(2,nres+i)
4231       dzi=dc_norm(3,nres+i)
4232 c      dsci_inv=dsc_inv(itypi)
4233       dsci_inv=vbld_inv(nres+i)
4234       itypj=itype(j)
4235 c      dscj_inv=dsc_inv(itypj)
4236       dscj_inv=vbld_inv(nres+j)
4237       xj=c(1,nres+j)-xi
4238       yj=c(2,nres+j)-yi
4239       zj=c(3,nres+j)-zi
4240       dxj=dc_norm(1,nres+j)
4241       dyj=dc_norm(2,nres+j)
4242       dzj=dc_norm(3,nres+j)
4243       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4244       rij=dsqrt(rrij)
4245       erij(1)=xj*rij
4246       erij(2)=yj*rij
4247       erij(3)=zj*rij
4248       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4249       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4250       om12=dxi*dxj+dyi*dyj+dzi*dzj
4251       do k=1,3
4252         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4253         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4254       enddo
4255       rij=1.0d0/rij
4256       deltad=rij-d0cm
4257       deltat1=1.0d0-om1
4258       deltat2=1.0d0+om2
4259       deltat12=om2-om1+2.0d0
4260       cosphi=om12-om1*om2
4261       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4262      &  +akct*deltad*deltat12
4263      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4264 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4265 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4266 c     &  " deltat12",deltat12," eij",eij
4267       ed=2*akcm*deltad+akct*deltat12
4268       pom1=akct*deltad
4269       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4270       eom1=-2*akth*deltat1-pom1-om2*pom2
4271       eom2= 2*akth*deltat2+pom1-om1*pom2
4272       eom12=pom2
4273       do k=1,3
4274         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4275         ghpbx(k,i)=ghpbx(k,i)-ggk
4276      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4277      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4278         ghpbx(k,j)=ghpbx(k,j)+ggk
4279      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4280      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4281         ghpbc(k,i)=ghpbc(k,i)-ggk
4282         ghpbc(k,j)=ghpbc(k,j)+ggk
4283       enddo
4284 C
4285 C Calculate the components of the gradient in DC and X
4286 C
4287 cgrad      do k=i,j-1
4288 cgrad        do l=1,3
4289 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4290 cgrad        enddo
4291 cgrad      enddo
4292       return
4293       end
4294 C--------------------------------------------------------------------------
4295       subroutine ebond(estr)
4296 c
4297 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4298 c
4299       implicit real*8 (a-h,o-z)
4300       include 'DIMENSIONS'
4301       include 'COMMON.LOCAL'
4302       include 'COMMON.GEO'
4303       include 'COMMON.INTERACT'
4304       include 'COMMON.DERIV'
4305       include 'COMMON.VAR'
4306       include 'COMMON.CHAIN'
4307       include 'COMMON.IOUNITS'
4308       include 'COMMON.NAMES'
4309       include 'COMMON.FFIELD'
4310       include 'COMMON.CONTROL'
4311       include 'COMMON.SETUP'
4312       double precision u(3),ud(3)
4313       estr=0.0d0
4314       do i=ibondp_start,ibondp_end
4315         diff = vbld(i)-vbldp0
4316 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4317         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
4318      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4319         estr=estr+diff*diff
4320         do j=1,3
4321           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4322         enddo
4323 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4324       enddo
4325       estr=0.5d0*AKP*estr
4326 c
4327 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4328 c
4329       do i=ibond_start,ibond_end
4330         iti=itype(i)
4331         if (iti.ne.10) then
4332           nbi=nbondterm(iti)
4333           if (nbi.eq.1) then
4334             diff=vbld(i+nres)-vbldsc0(1,iti)
4335 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4336 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4337             if (energy_dec)  then
4338               write (iout,*)
4339      &         "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4340      &         AKSC(1,iti),AKSC(1,iti)*diff*diff
4341               call flush(iout)
4342             endif
4343             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4344             do j=1,3
4345               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4346             enddo
4347           else
4348             do j=1,nbi
4349               diff=vbld(i+nres)-vbldsc0(j,iti)
4350               ud(j)=aksc(j,iti)*diff
4351               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4352             enddo
4353             uprod=u(1)
4354             do j=2,nbi
4355               uprod=uprod*u(j)
4356             enddo
4357             usum=0.0d0
4358             usumsqder=0.0d0
4359             do j=1,nbi
4360               uprod1=1.0d0
4361               uprod2=1.0d0
4362               do k=1,nbi
4363                 if (k.ne.j) then
4364                   uprod1=uprod1*u(k)
4365                   uprod2=uprod2*u(k)*u(k)
4366                 endif
4367               enddo
4368               usum=usum+uprod1
4369               usumsqder=usumsqder+ud(j)*uprod2
4370             enddo
4371             estr=estr+uprod/usum
4372             do j=1,3
4373              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4374             enddo
4375           endif
4376         endif
4377       enddo
4378       return
4379       end
4380 #ifdef CRYST_THETA
4381 C--------------------------------------------------------------------------
4382       subroutine ebend(etheta)
4383 C
4384 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4385 C angles gamma and its derivatives in consecutive thetas and gammas.
4386 C
4387       implicit real*8 (a-h,o-z)
4388       include 'DIMENSIONS'
4389       include 'COMMON.LOCAL'
4390       include 'COMMON.GEO'
4391       include 'COMMON.INTERACT'
4392       include 'COMMON.DERIV'
4393       include 'COMMON.VAR'
4394       include 'COMMON.CHAIN'
4395       include 'COMMON.IOUNITS'
4396       include 'COMMON.NAMES'
4397       include 'COMMON.FFIELD'
4398       include 'COMMON.CONTROL'
4399       common /calcthet/ term1,term2,termm,diffak,ratak,
4400      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4401      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4402       double precision y(2),z(2)
4403       delta=0.02d0*pi
4404 c      time11=dexp(-2*time)
4405 c      time12=1.0d0
4406       etheta=0.0D0
4407 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4408       do i=ithet_start,ithet_end
4409 C Zero the energy function and its derivative at 0 or pi.
4410         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4411         it=itype(i-1)
4412         if (i.gt.3) then
4413 #ifdef OSF
4414           phii=phi(i)
4415           if (phii.ne.phii) phii=150.0
4416 #else
4417           phii=phi(i)
4418 #endif
4419           y(1)=dcos(phii)
4420           y(2)=dsin(phii)
4421         else
4422           y(1)=0.0D0
4423           y(2)=0.0D0
4424         endif
4425         if (i.lt.nres) then
4426 #ifdef OSF
4427           phii1=phi(i+1)
4428           if (phii1.ne.phii1) phii1=150.0
4429           phii1=pinorm(phii1)
4430           z(1)=cos(phii1)
4431 #else
4432           phii1=phi(i+1)
4433           z(1)=dcos(phii1)
4434 #endif
4435           z(2)=dsin(phii1)
4436         else
4437           z(1)=0.0D0
4438           z(2)=0.0D0
4439         endif
4440 C Calculate the "mean" value of theta from the part of the distribution
4441 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4442 C In following comments this theta will be referred to as t_c.
4443         thet_pred_mean=0.0d0
4444         do k=1,2
4445           athetk=athet(k,it)
4446           bthetk=bthet(k,it)
4447           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4448         enddo
4449         dthett=thet_pred_mean*ssd
4450         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4451 C Derivatives of the "mean" values in gamma1 and gamma2.
4452         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4453         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4454         if (theta(i).gt.pi-delta) then
4455           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4456      &         E_tc0)
4457           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4458           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4459           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4460      &        E_theta)
4461           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4462      &        E_tc)
4463         else if (theta(i).lt.delta) then
4464           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4465           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4466           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4467      &        E_theta)
4468           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4469           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4470      &        E_tc)
4471         else
4472           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4473      &        E_theta,E_tc)
4474         endif
4475         etheta=etheta+ethetai
4476         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4477      &      'ebend',i,ethetai
4478         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4479         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4480         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4481       enddo
4482 C Ufff.... We've done all this!!!
4483       return
4484       end
4485 C---------------------------------------------------------------------------
4486       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4487      &     E_tc)
4488       implicit real*8 (a-h,o-z)
4489       include 'DIMENSIONS'
4490       include 'COMMON.LOCAL'
4491       include 'COMMON.IOUNITS'
4492       common /calcthet/ term1,term2,termm,diffak,ratak,
4493      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4494      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4495 C Calculate the contributions to both Gaussian lobes.
4496 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4497 C The "polynomial part" of the "standard deviation" of this part of
4498 C the distribution.
4499         sig=polthet(3,it)
4500         do j=2,0,-1
4501           sig=sig*thet_pred_mean+polthet(j,it)
4502         enddo
4503 C Derivative of the "interior part" of the "standard deviation of the"
4504 C gamma-dependent Gaussian lobe in t_c.
4505         sigtc=3*polthet(3,it)
4506         do j=2,1,-1
4507           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4508         enddo
4509         sigtc=sig*sigtc
4510 C Set the parameters of both Gaussian lobes of the distribution.
4511 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4512         fac=sig*sig+sigc0(it)
4513         sigcsq=fac+fac
4514         sigc=1.0D0/sigcsq
4515 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4516         sigsqtc=-4.0D0*sigcsq*sigtc
4517 c       print *,i,sig,sigtc,sigsqtc
4518 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4519         sigtc=-sigtc/(fac*fac)
4520 C Following variable is sigma(t_c)**(-2)
4521         sigcsq=sigcsq*sigcsq
4522         sig0i=sig0(it)
4523         sig0inv=1.0D0/sig0i**2
4524         delthec=thetai-thet_pred_mean
4525         delthe0=thetai-theta0i
4526         term1=-0.5D0*sigcsq*delthec*delthec
4527         term2=-0.5D0*sig0inv*delthe0*delthe0
4528 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4529 C NaNs in taking the logarithm. We extract the largest exponent which is added
4530 C to the energy (this being the log of the distribution) at the end of energy
4531 C term evaluation for this virtual-bond angle.
4532         if (term1.gt.term2) then
4533           termm=term1
4534           term2=dexp(term2-termm)
4535           term1=1.0d0
4536         else
4537           termm=term2
4538           term1=dexp(term1-termm)
4539           term2=1.0d0
4540         endif
4541 C The ratio between the gamma-independent and gamma-dependent lobes of
4542 C the distribution is a Gaussian function of thet_pred_mean too.
4543         diffak=gthet(2,it)-thet_pred_mean
4544         ratak=diffak/gthet(3,it)**2
4545         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4546 C Let's differentiate it in thet_pred_mean NOW.
4547         aktc=ak*ratak
4548 C Now put together the distribution terms to make complete distribution.
4549         termexp=term1+ak*term2
4550         termpre=sigc+ak*sig0i
4551 C Contribution of the bending energy from this theta is just the -log of
4552 C the sum of the contributions from the two lobes and the pre-exponential
4553 C factor. Simple enough, isn't it?
4554         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4555 C NOW the derivatives!!!
4556 C 6/6/97 Take into account the deformation.
4557         E_theta=(delthec*sigcsq*term1
4558      &       +ak*delthe0*sig0inv*term2)/termexp
4559         E_tc=((sigtc+aktc*sig0i)/termpre
4560      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4561      &       aktc*term2)/termexp)
4562       return
4563       end
4564 c-----------------------------------------------------------------------------
4565       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4566       implicit real*8 (a-h,o-z)
4567       include 'DIMENSIONS'
4568       include 'COMMON.LOCAL'
4569       include 'COMMON.IOUNITS'
4570       common /calcthet/ term1,term2,termm,diffak,ratak,
4571      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4572      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4573       delthec=thetai-thet_pred_mean
4574       delthe0=thetai-theta0i
4575 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4576       t3 = thetai-thet_pred_mean
4577       t6 = t3**2
4578       t9 = term1
4579       t12 = t3*sigcsq
4580       t14 = t12+t6*sigsqtc
4581       t16 = 1.0d0
4582       t21 = thetai-theta0i
4583       t23 = t21**2
4584       t26 = term2
4585       t27 = t21*t26
4586       t32 = termexp
4587       t40 = t32**2
4588       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4589      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4590      & *(-t12*t9-ak*sig0inv*t27)
4591       return
4592       end
4593 #else
4594 C--------------------------------------------------------------------------
4595       subroutine ebend(etheta)
4596 C
4597 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4598 C angles gamma and its derivatives in consecutive thetas and gammas.
4599 C ab initio-derived potentials from
4600 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4601 C
4602       implicit real*8 (a-h,o-z)
4603       include 'DIMENSIONS'
4604       include 'COMMON.LOCAL'
4605       include 'COMMON.GEO'
4606       include 'COMMON.INTERACT'
4607       include 'COMMON.DERIV'
4608       include 'COMMON.VAR'
4609       include 'COMMON.CHAIN'
4610       include 'COMMON.IOUNITS'
4611       include 'COMMON.NAMES'
4612       include 'COMMON.FFIELD'
4613       include 'COMMON.CONTROL'
4614       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4615      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4616      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4617      & sinph1ph2(maxdouble,maxdouble)
4618       logical lprn /.false./, lprn1 /.false./
4619       etheta=0.0D0
4620       do i=ithet_start,ithet_end
4621         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4622      &(itype(i).eq.ntyp1)) cycle
4623         dethetai=0.0d0
4624         dephii=0.0d0
4625         dephii1=0.0d0
4626         theti2=0.5d0*theta(i)
4627         ityp2=ithetyp(itype(i-1))
4628         do k=1,nntheterm
4629           coskt(k)=dcos(k*theti2)
4630           sinkt(k)=dsin(k*theti2)
4631         enddo
4632 C        if (i.gt.3) then
4633         if (i.gt.3 .and. itype(imax0(i-3,1)).ne.ntyp1) then
4634 #ifdef OSF
4635           phii=phi(i)
4636           if (phii.ne.phii) phii=150.0
4637 #else
4638           phii=phi(i)
4639 #endif
4640           ityp1=ithetyp(itype(i-2))
4641           do k=1,nsingle
4642             cosph1(k)=dcos(k*phii)
4643             sinph1(k)=dsin(k*phii)
4644           enddo
4645         else
4646           phii=0.0d0
4647           ityp1=ithetyp(itype(i-2))
4648           do k=1,nsingle
4649             cosph1(k)=0.0d0
4650             sinph1(k)=0.0d0
4651           enddo
4652         endif
4653         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4654 #ifdef OSF
4655           phii1=phi(i+1)
4656           if (phii1.ne.phii1) phii1=150.0
4657           phii1=pinorm(phii1)
4658 #else
4659           phii1=phi(i+1)
4660 #endif
4661           ityp3=ithetyp(itype(i))
4662           do k=1,nsingle
4663             cosph2(k)=dcos(k*phii1)
4664             sinph2(k)=dsin(k*phii1)
4665           enddo
4666         else
4667           phii1=0.0d0
4668           ityp3=ithetyp(itype(i))
4669           do k=1,nsingle
4670             cosph2(k)=0.0d0
4671             sinph2(k)=0.0d0
4672           enddo
4673         endif
4674         ethetai=aa0thet(ityp1,ityp2,ityp3)
4675         do k=1,ndouble
4676           do l=1,k-1
4677             ccl=cosph1(l)*cosph2(k-l)
4678             ssl=sinph1(l)*sinph2(k-l)
4679             scl=sinph1(l)*cosph2(k-l)
4680             csl=cosph1(l)*sinph2(k-l)
4681             cosph1ph2(l,k)=ccl-ssl
4682             cosph1ph2(k,l)=ccl+ssl
4683             sinph1ph2(l,k)=scl+csl
4684             sinph1ph2(k,l)=scl-csl
4685           enddo
4686         enddo
4687         if (lprn) then
4688         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4689      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4690         write (iout,*) "coskt and sinkt"
4691         do k=1,nntheterm
4692           write (iout,*) k,coskt(k),sinkt(k)
4693         enddo
4694         endif
4695         do k=1,ntheterm
4696           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4697           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4698      &      *coskt(k)
4699           if (lprn)
4700      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4701      &     " ethetai",ethetai
4702         enddo
4703         if (lprn) then
4704         write (iout,*) "cosph and sinph"
4705         do k=1,nsingle
4706           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4707         enddo
4708         write (iout,*) "cosph1ph2 and sinph2ph2"
4709         do k=2,ndouble
4710           do l=1,k-1
4711             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4712      &         sinph1ph2(l,k),sinph1ph2(k,l)
4713           enddo
4714         enddo
4715         write(iout,*) "ethetai",ethetai
4716         endif
4717         do m=1,ntheterm2
4718           do k=1,nsingle
4719             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4720      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4721      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4722      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4723             ethetai=ethetai+sinkt(m)*aux
4724             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4725             dephii=dephii+k*sinkt(m)*(
4726      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4727      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4728             dephii1=dephii1+k*sinkt(m)*(
4729      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4730      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4731             if (lprn)
4732      &      write (iout,*) "m",m," k",k," bbthet",
4733      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4734      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4735      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4736      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4737           enddo
4738         enddo
4739         if (lprn)
4740      &  write(iout,*) "ethetai",ethetai
4741         do m=1,ntheterm3
4742           do k=2,ndouble
4743             do l=1,k-1
4744               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4745      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4746      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4747      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4748               ethetai=ethetai+sinkt(m)*aux
4749               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4750               dephii=dephii+l*sinkt(m)*(
4751      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4752      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4753      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4754      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4755               dephii1=dephii1+(k-l)*sinkt(m)*(
4756      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4757      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4758      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4759      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4760               if (lprn) then
4761               write (iout,*) "m",m," k",k," l",l," ffthet",
4762      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4763      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4764      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4765      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4766               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4767      &            cosph1ph2(k,l)*sinkt(m),
4768      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4769               endif
4770             enddo
4771           enddo
4772         enddo
4773 10      continue
4774         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4775      &   i,theta(i)*rad2deg,phii*rad2deg,
4776      &   phii1*rad2deg,ethetai
4777         etheta=etheta+ethetai
4778         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4779      &      'ebend',i,ethetai
4780         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4781         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4782         gloc(nphi+i-2,icg)=wang*dethetai
4783       enddo
4784       return
4785       end
4786 #endif
4787 #ifdef CRYST_SC
4788 c-----------------------------------------------------------------------------
4789       subroutine esc(escloc)
4790 C Calculate the local energy of a side chain and its derivatives in the
4791 C corresponding virtual-bond valence angles THETA and the spherical angles
4792 C ALPHA and OMEGA.
4793       implicit real*8 (a-h,o-z)
4794       include 'DIMENSIONS'
4795       include 'COMMON.GEO'
4796       include 'COMMON.LOCAL'
4797       include 'COMMON.VAR'
4798       include 'COMMON.INTERACT'
4799       include 'COMMON.DERIV'
4800       include 'COMMON.CHAIN'
4801       include 'COMMON.IOUNITS'
4802       include 'COMMON.NAMES'
4803       include 'COMMON.FFIELD'
4804       include 'COMMON.CONTROL'
4805       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4806      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4807       common /sccalc/ time11,time12,time112,theti,it,nlobit
4808       delta=0.02d0*pi
4809       escloc=0.0D0
4810 c     write (iout,'(a)') 'ESC'
4811       do i=loc_start,loc_end
4812         it=itype(i)
4813         if (it.eq.10) goto 1
4814         nlobit=nlob(it)
4815 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4816 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4817         theti=theta(i+1)-pipol
4818         x(1)=dtan(theti)
4819         x(2)=alph(i)
4820         x(3)=omeg(i)
4821
4822         if (x(2).gt.pi-delta) then
4823           xtemp(1)=x(1)
4824           xtemp(2)=pi-delta
4825           xtemp(3)=x(3)
4826           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4827           xtemp(2)=pi
4828           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4829           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4830      &        escloci,dersc(2))
4831           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4832      &        ddersc0(1),dersc(1))
4833           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4834      &        ddersc0(3),dersc(3))
4835           xtemp(2)=pi-delta
4836           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4837           xtemp(2)=pi
4838           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4839           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4840      &            dersc0(2),esclocbi,dersc02)
4841           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4842      &            dersc12,dersc01)
4843           call splinthet(x(2),0.5d0*delta,ss,ssd)
4844           dersc0(1)=dersc01
4845           dersc0(2)=dersc02
4846           dersc0(3)=0.0d0
4847           do k=1,3
4848             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4849           enddo
4850           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4851 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4852 c    &             esclocbi,ss,ssd
4853           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4854 c         escloci=esclocbi
4855 c         write (iout,*) escloci
4856         else if (x(2).lt.delta) then
4857           xtemp(1)=x(1)
4858           xtemp(2)=delta
4859           xtemp(3)=x(3)
4860           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4861           xtemp(2)=0.0d0
4862           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4863           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4864      &        escloci,dersc(2))
4865           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4866      &        ddersc0(1),dersc(1))
4867           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4868      &        ddersc0(3),dersc(3))
4869           xtemp(2)=delta
4870           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4871           xtemp(2)=0.0d0
4872           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4873           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4874      &            dersc0(2),esclocbi,dersc02)
4875           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4876      &            dersc12,dersc01)
4877           dersc0(1)=dersc01
4878           dersc0(2)=dersc02
4879           dersc0(3)=0.0d0
4880           call splinthet(x(2),0.5d0*delta,ss,ssd)
4881           do k=1,3
4882             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4883           enddo
4884           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4885 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4886 c    &             esclocbi,ss,ssd
4887           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4888 c         write (iout,*) escloci
4889         else
4890           call enesc(x,escloci,dersc,ddummy,.false.)
4891         endif
4892
4893         escloc=escloc+escloci
4894         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4895      &     'escloc',i,escloci
4896 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4897
4898         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4899      &   wscloc*dersc(1)
4900         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4901         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4902     1   continue
4903       enddo
4904       return
4905       end
4906 C---------------------------------------------------------------------------
4907       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4908       implicit real*8 (a-h,o-z)
4909       include 'DIMENSIONS'
4910       include 'COMMON.GEO'
4911       include 'COMMON.LOCAL'
4912       include 'COMMON.IOUNITS'
4913       common /sccalc/ time11,time12,time112,theti,it,nlobit
4914       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4915       double precision contr(maxlob,-1:1)
4916       logical mixed
4917 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4918         escloc_i=0.0D0
4919         do j=1,3
4920           dersc(j)=0.0D0
4921           if (mixed) ddersc(j)=0.0d0
4922         enddo
4923         x3=x(3)
4924
4925 C Because of periodicity of the dependence of the SC energy in omega we have
4926 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4927 C To avoid underflows, first compute & store the exponents.
4928
4929         do iii=-1,1
4930
4931           x(3)=x3+iii*dwapi
4932
4933           do j=1,nlobit
4934             do k=1,3
4935               z(k)=x(k)-censc(k,j,it)
4936             enddo
4937             do k=1,3
4938               Axk=0.0D0
4939               do l=1,3
4940                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4941               enddo
4942               Ax(k,j,iii)=Axk
4943             enddo
4944             expfac=0.0D0
4945             do k=1,3
4946               expfac=expfac+Ax(k,j,iii)*z(k)
4947             enddo
4948             contr(j,iii)=expfac
4949           enddo ! j
4950
4951         enddo ! iii
4952
4953         x(3)=x3
4954 C As in the case of ebend, we want to avoid underflows in exponentiation and
4955 C subsequent NaNs and INFs in energy calculation.
4956 C Find the largest exponent
4957         emin=contr(1,-1)
4958         do iii=-1,1
4959           do j=1,nlobit
4960             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4961           enddo
4962         enddo
4963         emin=0.5D0*emin
4964 cd      print *,'it=',it,' emin=',emin
4965
4966 C Compute the contribution to SC energy and derivatives
4967         do iii=-1,1
4968
4969           do j=1,nlobit
4970 #ifdef OSF
4971             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4972             if(adexp.ne.adexp) adexp=1.0
4973             expfac=dexp(adexp)
4974 #else
4975             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4976 #endif
4977 cd          print *,'j=',j,' expfac=',expfac
4978             escloc_i=escloc_i+expfac
4979             do k=1,3
4980               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4981             enddo
4982             if (mixed) then
4983               do k=1,3,2
4984                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4985      &            +gaussc(k,2,j,it))*expfac
4986               enddo
4987             endif
4988           enddo
4989
4990         enddo ! iii
4991
4992         dersc(1)=dersc(1)/cos(theti)**2
4993         ddersc(1)=ddersc(1)/cos(theti)**2
4994         ddersc(3)=ddersc(3)
4995
4996         escloci=-(dlog(escloc_i)-emin)
4997         do j=1,3
4998           dersc(j)=dersc(j)/escloc_i
4999         enddo
5000         if (mixed) then
5001           do j=1,3,2
5002             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5003           enddo
5004         endif
5005       return
5006       end
5007 C------------------------------------------------------------------------------
5008       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5009       implicit real*8 (a-h,o-z)
5010       include 'DIMENSIONS'
5011       include 'COMMON.GEO'
5012       include 'COMMON.LOCAL'
5013       include 'COMMON.IOUNITS'
5014       common /sccalc/ time11,time12,time112,theti,it,nlobit
5015       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5016       double precision contr(maxlob)
5017       logical mixed
5018
5019       escloc_i=0.0D0
5020
5021       do j=1,3
5022         dersc(j)=0.0D0
5023       enddo
5024
5025       do j=1,nlobit
5026         do k=1,2
5027           z(k)=x(k)-censc(k,j,it)
5028         enddo
5029         z(3)=dwapi
5030         do k=1,3
5031           Axk=0.0D0
5032           do l=1,3
5033             Axk=Axk+gaussc(l,k,j,it)*z(l)
5034           enddo
5035           Ax(k,j)=Axk
5036         enddo
5037         expfac=0.0D0
5038         do k=1,3
5039           expfac=expfac+Ax(k,j)*z(k)
5040         enddo
5041         contr(j)=expfac
5042       enddo ! j
5043
5044 C As in the case of ebend, we want to avoid underflows in exponentiation and
5045 C subsequent NaNs and INFs in energy calculation.
5046 C Find the largest exponent
5047       emin=contr(1)
5048       do j=1,nlobit
5049         if (emin.gt.contr(j)) emin=contr(j)
5050       enddo
5051       emin=0.5D0*emin
5052
5053 C Compute the contribution to SC energy and derivatives
5054
5055       dersc12=0.0d0
5056       do j=1,nlobit
5057         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5058         escloc_i=escloc_i+expfac
5059         do k=1,2
5060           dersc(k)=dersc(k)+Ax(k,j)*expfac
5061         enddo
5062         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5063      &            +gaussc(1,2,j,it))*expfac
5064         dersc(3)=0.0d0
5065       enddo
5066
5067       dersc(1)=dersc(1)/cos(theti)**2
5068       dersc12=dersc12/cos(theti)**2
5069       escloci=-(dlog(escloc_i)-emin)
5070       do j=1,2
5071         dersc(j)=dersc(j)/escloc_i
5072       enddo
5073       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5074       return
5075       end
5076 #else
5077 c----------------------------------------------------------------------------------
5078       subroutine esc(escloc)
5079 C Calculate the local energy of a side chain and its derivatives in the
5080 C corresponding virtual-bond valence angles THETA and the spherical angles
5081 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5082 C added by Urszula Kozlowska. 07/11/2007
5083 C
5084       implicit real*8 (a-h,o-z)
5085       include 'DIMENSIONS'
5086       include 'COMMON.GEO'
5087       include 'COMMON.LOCAL'
5088       include 'COMMON.VAR'
5089       include 'COMMON.SCROT'
5090       include 'COMMON.INTERACT'
5091       include 'COMMON.DERIV'
5092       include 'COMMON.CHAIN'
5093       include 'COMMON.IOUNITS'
5094       include 'COMMON.NAMES'
5095       include 'COMMON.FFIELD'
5096       include 'COMMON.CONTROL'
5097       include 'COMMON.VECTORS'
5098       double precision x_prime(3),y_prime(3),z_prime(3)
5099      &    , sumene,dsc_i,dp2_i,x(65),
5100      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5101      &    de_dxx,de_dyy,de_dzz,de_dt
5102       double precision s1_t,s1_6_t,s2_t,s2_6_t
5103       double precision
5104      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5105      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5106      & dt_dCi(3),dt_dCi1(3)
5107       common /sccalc/ time11,time12,time112,theti,it,nlobit
5108       delta=0.02d0*pi
5109       escloc=0.0D0
5110       do i=loc_start,loc_end
5111         costtab(i+1) =dcos(theta(i+1))
5112         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5113         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5114         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5115         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5116         cosfac=dsqrt(cosfac2)
5117         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5118         sinfac=dsqrt(sinfac2)
5119         it=itype(i)
5120         if (it.eq.10) goto 1
5121 c
5122 C  Compute the axes of tghe local cartesian coordinates system; store in
5123 c   x_prime, y_prime and z_prime
5124 c
5125         do j=1,3
5126           x_prime(j) = 0.00
5127           y_prime(j) = 0.00
5128           z_prime(j) = 0.00
5129         enddo
5130 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5131 C     &   dc_norm(3,i+nres)
5132         do j = 1,3
5133           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5134           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5135         enddo
5136         do j = 1,3
5137           z_prime(j) = -uz(j,i-1)
5138         enddo
5139 c       write (2,*) "i",i
5140 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5141 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5142 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5143 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5144 c      & " xy",scalar(x_prime(1),y_prime(1)),
5145 c      & " xz",scalar(x_prime(1),z_prime(1)),
5146 c      & " yy",scalar(y_prime(1),y_prime(1)),
5147 c      & " yz",scalar(y_prime(1),z_prime(1)),
5148 c      & " zz",scalar(z_prime(1),z_prime(1))
5149 c
5150 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5151 C to local coordinate system. Store in xx, yy, zz.
5152 c
5153         xx=0.0d0
5154         yy=0.0d0
5155         zz=0.0d0
5156         do j = 1,3
5157           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5158           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5159           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5160         enddo
5161
5162         xxtab(i)=xx
5163         yytab(i)=yy
5164         zztab(i)=zz
5165 C
5166 C Compute the energy of the ith side cbain
5167 C
5168 c        write (2,*) "xx",xx," yy",yy," zz",zz
5169         it=itype(i)
5170         do j = 1,65
5171           x(j) = sc_parmin(j,it)
5172         enddo
5173 #ifdef CHECK_COORD
5174 Cc diagnostics - remove later
5175         xx1 = dcos(alph(2))
5176         yy1 = dsin(alph(2))*dcos(omeg(2))
5177         zz1 = -dsin(alph(2))*dsin(omeg(2))
5178         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5179      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5180      &    xx1,yy1,zz1
5181 C,"  --- ", xx_w,yy_w,zz_w
5182 c end diagnostics
5183 #endif
5184         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5185      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5186      &   + x(10)*yy*zz
5187         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5188      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5189      & + x(20)*yy*zz
5190         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5191      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5192      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5193      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5194      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5195      &  +x(40)*xx*yy*zz
5196         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5197      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5198      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5199      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5200      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5201      &  +x(60)*xx*yy*zz
5202         dsc_i   = 0.743d0+x(61)
5203         dp2_i   = 1.9d0+x(62)
5204         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5205      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5206         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5207      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5208         s1=(1+x(63))/(0.1d0 + dscp1)
5209         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5210         s2=(1+x(65))/(0.1d0 + dscp2)
5211         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5212         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5213      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5214 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5215 c     &   sumene4,
5216 c     &   dscp1,dscp2,sumene
5217 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5218         escloc = escloc + sumene
5219 c        write (2,*) "i",i," escloc",sumene,escloc
5220 #ifdef DEBUG
5221 C
5222 C This section to check the numerical derivatives of the energy of ith side
5223 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5224 C #define DEBUG in the code to turn it on.
5225 C
5226         write (2,*) "sumene               =",sumene
5227         aincr=1.0d-7
5228         xxsave=xx
5229         xx=xx+aincr
5230         write (2,*) xx,yy,zz
5231         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5232         de_dxx_num=(sumenep-sumene)/aincr
5233         xx=xxsave
5234         write (2,*) "xx+ sumene from enesc=",sumenep
5235         yysave=yy
5236         yy=yy+aincr
5237         write (2,*) xx,yy,zz
5238         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5239         de_dyy_num=(sumenep-sumene)/aincr
5240         yy=yysave
5241         write (2,*) "yy+ sumene from enesc=",sumenep
5242         zzsave=zz
5243         zz=zz+aincr
5244         write (2,*) xx,yy,zz
5245         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5246         de_dzz_num=(sumenep-sumene)/aincr
5247         zz=zzsave
5248         write (2,*) "zz+ sumene from enesc=",sumenep
5249         costsave=cost2tab(i+1)
5250         sintsave=sint2tab(i+1)
5251         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5252         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5253         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5254         de_dt_num=(sumenep-sumene)/aincr
5255         write (2,*) " t+ sumene from enesc=",sumenep
5256         cost2tab(i+1)=costsave
5257         sint2tab(i+1)=sintsave
5258 C End of diagnostics section.
5259 #endif
5260 C
5261 C Compute the gradient of esc
5262 C
5263         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5264         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5265         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5266         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5267         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5268         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5269         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5270         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5271         pom1=(sumene3*sint2tab(i+1)+sumene1)
5272      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5273         pom2=(sumene4*cost2tab(i+1)+sumene2)
5274      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5275         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5276         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5277      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5278      &  +x(40)*yy*zz
5279         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5280         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5281      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5282      &  +x(60)*yy*zz
5283         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5284      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5285      &        +(pom1+pom2)*pom_dx
5286 #ifdef DEBUG
5287         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5288 #endif
5289 C
5290         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5291         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5292      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5293      &  +x(40)*xx*zz
5294         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5295         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5296      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5297      &  +x(59)*zz**2 +x(60)*xx*zz
5298         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5299      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5300      &        +(pom1-pom2)*pom_dy
5301 #ifdef DEBUG
5302         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5303 #endif
5304 C
5305         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5306      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5307      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5308      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5309      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5310      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5311      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5312      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5313 #ifdef DEBUG
5314         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5315 #endif
5316 C
5317         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5318      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5319      &  +pom1*pom_dt1+pom2*pom_dt2
5320 #ifdef DEBUG
5321         write(2,*), "de_dt = ", de_dt,de_dt_num
5322 #endif
5323 c
5324 C
5325        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5326        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5327        cosfac2xx=cosfac2*xx
5328        sinfac2yy=sinfac2*yy
5329        do k = 1,3
5330          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5331      &      vbld_inv(i+1)
5332          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5333      &      vbld_inv(i)
5334          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5335          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5336 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5337 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5338 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5339 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5340          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5341          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5342          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5343          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5344          dZZ_Ci1(k)=0.0d0
5345          dZZ_Ci(k)=0.0d0
5346          do j=1,3
5347            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5348            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5349          enddo
5350
5351          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5352          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5353          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5354 c
5355          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5356          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5357        enddo
5358
5359        do k=1,3
5360          dXX_Ctab(k,i)=dXX_Ci(k)
5361          dXX_C1tab(k,i)=dXX_Ci1(k)
5362          dYY_Ctab(k,i)=dYY_Ci(k)
5363          dYY_C1tab(k,i)=dYY_Ci1(k)
5364          dZZ_Ctab(k,i)=dZZ_Ci(k)
5365          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5366          dXX_XYZtab(k,i)=dXX_XYZ(k)
5367          dYY_XYZtab(k,i)=dYY_XYZ(k)
5368          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5369        enddo
5370
5371        do k = 1,3
5372 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5373 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5374 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5375 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5376 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5377 c     &    dt_dci(k)
5378 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5379 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5380          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5381      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5382          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5383      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5384          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5385      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5386        enddo
5387 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5388 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5389
5390 C to check gradient call subroutine check_grad
5391
5392     1 continue
5393       enddo
5394       return
5395       end
5396 c------------------------------------------------------------------------------
5397       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5398       implicit none
5399       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5400      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5401       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5402      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5403      &   + x(10)*yy*zz
5404       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5405      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5406      & + x(20)*yy*zz
5407       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5408      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5409      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5410      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5411      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5412      &  +x(40)*xx*yy*zz
5413       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5414      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5415      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5416      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5417      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5418      &  +x(60)*xx*yy*zz
5419       dsc_i   = 0.743d0+x(61)
5420       dp2_i   = 1.9d0+x(62)
5421       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5422      &          *(xx*cost2+yy*sint2))
5423       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5424      &          *(xx*cost2-yy*sint2))
5425       s1=(1+x(63))/(0.1d0 + dscp1)
5426       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5427       s2=(1+x(65))/(0.1d0 + dscp2)
5428       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5429       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5430      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5431       enesc=sumene
5432       return
5433       end
5434 #endif
5435 c------------------------------------------------------------------------------
5436       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5437 C
5438 C This procedure calculates two-body contact function g(rij) and its derivative:
5439 C
5440 C           eps0ij                                     !       x < -1
5441 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5442 C            0                                         !       x > 1
5443 C
5444 C where x=(rij-r0ij)/delta
5445 C
5446 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5447 C
5448       implicit none
5449       double precision rij,r0ij,eps0ij,fcont,fprimcont
5450       double precision x,x2,x4,delta
5451 c     delta=0.02D0*r0ij
5452 c      delta=0.2D0*r0ij
5453       x=(rij-r0ij)/delta
5454       if (x.lt.-1.0D0) then
5455         fcont=eps0ij
5456         fprimcont=0.0D0
5457       else if (x.le.1.0D0) then
5458         x2=x*x
5459         x4=x2*x2
5460         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5461         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5462       else
5463         fcont=0.0D0
5464         fprimcont=0.0D0
5465       endif
5466       return
5467       end
5468 c------------------------------------------------------------------------------
5469       subroutine splinthet(theti,delta,ss,ssder)
5470       implicit real*8 (a-h,o-z)
5471       include 'DIMENSIONS'
5472       include 'COMMON.VAR'
5473       include 'COMMON.GEO'
5474       thetup=pi-delta
5475       thetlow=delta
5476       if (theti.gt.pipol) then
5477         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5478       else
5479         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5480         ssder=-ssder
5481       endif
5482       return
5483       end
5484 c------------------------------------------------------------------------------
5485       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5486       implicit none
5487       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5488       double precision ksi,ksi2,ksi3,a1,a2,a3
5489       a1=fprim0*delta/(f1-f0)
5490       a2=3.0d0-2.0d0*a1
5491       a3=a1-2.0d0
5492       ksi=(x-x0)/delta
5493       ksi2=ksi*ksi
5494       ksi3=ksi2*ksi
5495       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5496       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5497       return
5498       end
5499 c------------------------------------------------------------------------------
5500       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5501       implicit none
5502       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5503       double precision ksi,ksi2,ksi3,a1,a2,a3
5504       ksi=(x-x0)/delta
5505       ksi2=ksi*ksi
5506       ksi3=ksi2*ksi
5507       a1=fprim0x*delta
5508       a2=3*(f1x-f0x)-2*fprim0x*delta
5509       a3=fprim0x*delta-2*(f1x-f0x)
5510       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5511       return
5512       end
5513 C-----------------------------------------------------------------------------
5514 #ifdef CRYST_TOR
5515 C-----------------------------------------------------------------------------
5516       subroutine etor(etors,edihcnstr)
5517       implicit real*8 (a-h,o-z)
5518       include 'DIMENSIONS'
5519       include 'COMMON.VAR'
5520       include 'COMMON.GEO'
5521       include 'COMMON.LOCAL'
5522       include 'COMMON.TORSION'
5523       include 'COMMON.INTERACT'
5524       include 'COMMON.DERIV'
5525       include 'COMMON.CHAIN'
5526       include 'COMMON.NAMES'
5527       include 'COMMON.IOUNITS'
5528       include 'COMMON.FFIELD'
5529       include 'COMMON.TORCNSTR'
5530       include 'COMMON.CONTROL'
5531       logical lprn
5532 C Set lprn=.true. for debugging
5533       lprn=.false.
5534 c      lprn=.true.
5535       etors=0.0D0
5536       do i=iphi_start,iphi_end
5537       etors_ii=0.0D0
5538         itori=itortyp(itype(i-2))
5539         itori1=itortyp(itype(i-1))
5540         phii=phi(i)
5541         gloci=0.0D0
5542 C Proline-Proline pair is a special case...
5543         if (itori.eq.3 .and. itori1.eq.3) then
5544           if (phii.gt.-dwapi3) then
5545             cosphi=dcos(3*phii)
5546             fac=1.0D0/(1.0D0-cosphi)
5547             etorsi=v1(1,3,3)*fac
5548             etorsi=etorsi+etorsi
5549             etors=etors+etorsi-v1(1,3,3)
5550             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5551             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5552           endif
5553           do j=1,3
5554             v1ij=v1(j+1,itori,itori1)
5555             v2ij=v2(j+1,itori,itori1)
5556             cosphi=dcos(j*phii)
5557             sinphi=dsin(j*phii)
5558             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5559             if (energy_dec) etors_ii=etors_ii+
5560      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5561             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5562           enddo
5563         else
5564           do j=1,nterm_old
5565             v1ij=v1(j,itori,itori1)
5566             v2ij=v2(j,itori,itori1)
5567             cosphi=dcos(j*phii)
5568             sinphi=dsin(j*phii)
5569             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5570             if (energy_dec) etors_ii=etors_ii+
5571      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5572             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5573           enddo
5574         endif
5575         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5576      &        'etor',i,etors_ii
5577         if (lprn)
5578      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5579      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5580      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5581         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5582 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5583       enddo
5584 ! 6/20/98 - dihedral angle constraints
5585       edihcnstr=0.0d0
5586       do i=1,ndih_constr
5587         itori=idih_constr(i)
5588         phii=phi(itori)
5589         difi=phii-phi0(i)
5590         if (difi.gt.drange(i)) then
5591           difi=difi-drange(i)
5592           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5593           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5594         else if (difi.lt.-drange(i)) then
5595           difi=difi+drange(i)
5596           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5597           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5598         endif
5599 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5600 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5601       enddo
5602 !      write (iout,*) 'edihcnstr',edihcnstr
5603       return
5604       end
5605 c------------------------------------------------------------------------------
5606       subroutine etor_d(etors_d)
5607       etors_d=0.0d0
5608       return
5609       end
5610 c----------------------------------------------------------------------------
5611 #else
5612       subroutine etor(etors,edihcnstr)
5613       implicit real*8 (a-h,o-z)
5614       include 'DIMENSIONS'
5615       include 'COMMON.VAR'
5616       include 'COMMON.GEO'
5617       include 'COMMON.LOCAL'
5618       include 'COMMON.TORSION'
5619       include 'COMMON.INTERACT'
5620       include 'COMMON.DERIV'
5621       include 'COMMON.CHAIN'
5622       include 'COMMON.NAMES'
5623       include 'COMMON.IOUNITS'
5624       include 'COMMON.FFIELD'
5625       include 'COMMON.TORCNSTR'
5626       include 'COMMON.CONTROL'
5627       logical lprn
5628 C Set lprn=.true. for debugging
5629       lprn=.false.
5630 c     lprn=.true.
5631       etors=0.0D0
5632       do i=iphi_start,iphi_end
5633       etors_ii=0.0D0
5634         itori=itortyp(itype(i-2))
5635         itori1=itortyp(itype(i-1))
5636         phii=phi(i)
5637         gloci=0.0D0
5638 C Regular cosine and sine terms
5639         do j=1,nterm(itori,itori1)
5640           v1ij=v1(j,itori,itori1)
5641           v2ij=v2(j,itori,itori1)
5642           cosphi=dcos(j*phii)
5643           sinphi=dsin(j*phii)
5644           etors=etors+v1ij*cosphi+v2ij*sinphi
5645           if (energy_dec) etors_ii=etors_ii+
5646      &                v1ij*cosphi+v2ij*sinphi
5647           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5648         enddo
5649 C Lorentz terms
5650 C                         v1
5651 C  E = SUM ----------------------------------- - v1
5652 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5653 C
5654         cosphi=dcos(0.5d0*phii)
5655         sinphi=dsin(0.5d0*phii)
5656         do j=1,nlor(itori,itori1)
5657           vl1ij=vlor1(j,itori,itori1)
5658           vl2ij=vlor2(j,itori,itori1)
5659           vl3ij=vlor3(j,itori,itori1)
5660           pom=vl2ij*cosphi+vl3ij*sinphi
5661           pom1=1.0d0/(pom*pom+1.0d0)
5662           etors=etors+vl1ij*pom1
5663           if (energy_dec) etors_ii=etors_ii+
5664      &                vl1ij*pom1
5665           pom=-pom*pom1*pom1
5666           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5667         enddo
5668 C Subtract the constant term
5669         etors=etors-v0(itori,itori1)
5670           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5671      &         'etor',i,etors_ii-v0(itori,itori1)
5672         if (lprn)
5673      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5674      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5675      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5676         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5677 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5678       enddo
5679 ! 6/20/98 - dihedral angle constraints
5680       edihcnstr=0.0d0
5681 c      do i=1,ndih_constr
5682       do i=idihconstr_start,idihconstr_end
5683         itori=idih_constr(i)
5684         phii=phi(itori)
5685         difi=pinorm(phii-phi0(i))
5686         if (difi.gt.drange(i)) then
5687           difi=difi-drange(i)
5688           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5689           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5690         else if (difi.lt.-drange(i)) then
5691           difi=difi+drange(i)
5692           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5693           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5694         else
5695           difi=0.0
5696         endif
5697 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5698 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5699 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5700       enddo
5701 cd       write (iout,*) 'edihcnstr',edihcnstr
5702       return
5703       end
5704 c----------------------------------------------------------------------------
5705       subroutine etor_d(etors_d)
5706 C 6/23/01 Compute double torsional energy
5707       implicit real*8 (a-h,o-z)
5708       include 'DIMENSIONS'
5709       include 'COMMON.VAR'
5710       include 'COMMON.GEO'
5711       include 'COMMON.LOCAL'
5712       include 'COMMON.TORSION'
5713       include 'COMMON.INTERACT'
5714       include 'COMMON.DERIV'
5715       include 'COMMON.CHAIN'
5716       include 'COMMON.NAMES'
5717       include 'COMMON.IOUNITS'
5718       include 'COMMON.FFIELD'
5719       include 'COMMON.TORCNSTR'
5720       include 'COMMON.CONTROL'
5721       logical lprn
5722 C Set lprn=.true. for debugging
5723       lprn=.false.
5724 c     lprn=.true.
5725       etors_d=0.0D0
5726       do i=iphid_start,iphid_end
5727         etors_d_ii=0.0D0
5728         itori=itortyp(itype(i-2))
5729         itori1=itortyp(itype(i-1))
5730         itori2=itortyp(itype(i))
5731         phii=phi(i)
5732         phii1=phi(i+1)
5733         gloci1=0.0D0
5734         gloci2=0.0D0
5735 C Regular cosine and sine terms
5736         do j=1,ntermd_1(itori,itori1,itori2)
5737           v1cij=v1c(1,j,itori,itori1,itori2)
5738           v1sij=v1s(1,j,itori,itori1,itori2)
5739           v2cij=v1c(2,j,itori,itori1,itori2)
5740           v2sij=v1s(2,j,itori,itori1,itori2)
5741           cosphi1=dcos(j*phii)
5742           sinphi1=dsin(j*phii)
5743           cosphi2=dcos(j*phii1)
5744           sinphi2=dsin(j*phii1)
5745           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5746      &     v2cij*cosphi2+v2sij*sinphi2
5747           if (energy_dec) etors_d_ii=etors_d_ii+
5748      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5749           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5750           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5751         enddo
5752         do k=2,ntermd_2(itori,itori1,itori2)
5753           do l=1,k-1
5754             v1cdij = v2c(k,l,itori,itori1,itori2)
5755             v2cdij = v2c(l,k,itori,itori1,itori2)
5756             v1sdij = v2s(k,l,itori,itori1,itori2)
5757             v2sdij = v2s(l,k,itori,itori1,itori2)
5758             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5759             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5760             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5761             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5762             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5763      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5764             if (energy_dec) etors_d_ii=etors_d_ii+
5765      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5766      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5767             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5768      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5769             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5770      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5771           enddo
5772         enddo
5773         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5774      &        'etor_d',i,etors_d_ii
5775         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5776         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5777       enddo
5778       return
5779       end
5780 #endif
5781 c------------------------------------------------------------------------------
5782       subroutine eback_sc_corr(esccor)
5783 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5784 c        conformational states; temporarily implemented as differences
5785 c        between UNRES torsional potentials (dependent on three types of
5786 c        residues) and the torsional potentials dependent on all 20 types
5787 c        of residues computed from AM1  energy surfaces of terminally-blocked
5788 c        amino-acid residues.
5789       implicit real*8 (a-h,o-z)
5790       include 'DIMENSIONS'
5791       include 'COMMON.VAR'
5792       include 'COMMON.GEO'
5793       include 'COMMON.LOCAL'
5794       include 'COMMON.TORSION'
5795       include 'COMMON.SCCOR'
5796       include 'COMMON.INTERACT'
5797       include 'COMMON.DERIV'
5798       include 'COMMON.CHAIN'
5799       include 'COMMON.NAMES'
5800       include 'COMMON.IOUNITS'
5801       include 'COMMON.FFIELD'
5802       include 'COMMON.CONTROL'
5803       logical lprn
5804 C Set lprn=.true. for debugging
5805 C Set lprn=.true. for debugging
5806       lprn=.false.
5807 c      lprn=.true.
5808 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5809       esccor=0.0D0
5810       do i=itau_start,itau_end
5811         esccor_ii=0.0D0
5812         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5813         isccori=isccortyp(itype(i-2))
5814         isccori1=isccortyp(itype(i-1))
5815 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5816         phii=phi(i)
5817
5818 cccc  Added 9 May 2012
5819 cc Tauangle is torsional engle depending on the value of first digit
5820 c(see comment below)
5821 cc Omicron is flat angle depending on the value of first digit
5822 c(see comment below)
5823 C        print *,i,tauangle(1,i)
5824
5825 c        do intertyp=1,3 !intertyp
5826         do intertyp=2,2 !intertyp
5827 cc Added 09 May 2012 (Adasko)
5828 cc  Intertyp means interaction type of backbone mainchain correlation:
5829 c   1 = SC...Ca...Ca...Ca
5830 c   2 = Ca...Ca...Ca...SC
5831 c   3 = SC...Ca...Ca...SCi
5832         gloci=0.0D0
5833         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5834      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5835      &      (itype(i-1).eq.21)))
5836      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5837      &     .or.(itype(i-2).eq.21)))
5838      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5839      &      (itype(i-1).eq.21)))) cycle
5840         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5841         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5842      & cycle
5843         do j=1,nterm_sccor(isccori,isccori1)
5844           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5845           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5846           cosphi=dcos(j*tauangle(intertyp,i))
5847           sinphi=dsin(j*tauangle(intertyp,i))
5848           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5849           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5850         enddo
5851 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
5852         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5853 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5854 c     &gloc_sc(intertyp,i-3,icg)
5855         if (lprn)
5856      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5857      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5858      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5859      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5860         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5861        enddo !intertyp
5862       enddo
5863 c        do i=1,nres
5864 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc_sc(2,i,icg),
5865 c     &   gloc_sc(3,i,icg)
5866 c        enddo
5867       return
5868       end
5869 c----------------------------------------------------------------------------
5870       subroutine multibody(ecorr)
5871 C This subroutine calculates multi-body contributions to energy following
5872 C the idea of Skolnick et al. If side chains I and J make a contact and
5873 C at the same time side chains I+1 and J+1 make a contact, an extra
5874 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5875       implicit real*8 (a-h,o-z)
5876       include 'DIMENSIONS'
5877       include 'COMMON.IOUNITS'
5878       include 'COMMON.DERIV'
5879       include 'COMMON.INTERACT'
5880       include 'COMMON.CONTACTS'
5881       double precision gx(3),gx1(3)
5882       logical lprn
5883
5884 C Set lprn=.true. for debugging
5885       lprn=.false.
5886
5887       if (lprn) then
5888         write (iout,'(a)') 'Contact function values:'
5889         do i=nnt,nct-2
5890           write (iout,'(i2,20(1x,i2,f10.5))')
5891      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5892         enddo
5893       endif
5894       ecorr=0.0D0
5895       do i=nnt,nct
5896         do j=1,3
5897           gradcorr(j,i)=0.0D0
5898           gradxorr(j,i)=0.0D0
5899         enddo
5900       enddo
5901       do i=nnt,nct-2
5902
5903         DO ISHIFT = 3,4
5904
5905         i1=i+ishift
5906         num_conti=num_cont(i)
5907         num_conti1=num_cont(i1)
5908         do jj=1,num_conti
5909           j=jcont(jj,i)
5910           do kk=1,num_conti1
5911             j1=jcont(kk,i1)
5912             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5913 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5914 cd   &                   ' ishift=',ishift
5915 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5916 C The system gains extra energy.
5917               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5918             endif   ! j1==j+-ishift
5919           enddo     ! kk
5920         enddo       ! jj
5921
5922         ENDDO ! ISHIFT
5923
5924       enddo         ! i
5925       return
5926       end
5927 c------------------------------------------------------------------------------
5928       double precision function esccorr(i,j,k,l,jj,kk)
5929       implicit real*8 (a-h,o-z)
5930       include 'DIMENSIONS'
5931       include 'COMMON.IOUNITS'
5932       include 'COMMON.DERIV'
5933       include 'COMMON.INTERACT'
5934       include 'COMMON.CONTACTS'
5935       double precision gx(3),gx1(3)
5936       logical lprn
5937       lprn=.false.
5938       eij=facont(jj,i)
5939       ekl=facont(kk,k)
5940 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5941 C Calculate the multi-body contribution to energy.
5942 C Calculate multi-body contributions to the gradient.
5943 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5944 cd   & k,l,(gacont(m,kk,k),m=1,3)
5945       do m=1,3
5946         gx(m) =ekl*gacont(m,jj,i)
5947         gx1(m)=eij*gacont(m,kk,k)
5948         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5949         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5950         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5951         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5952       enddo
5953       do m=i,j-1
5954         do ll=1,3
5955           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5956         enddo
5957       enddo
5958       do m=k,l-1
5959         do ll=1,3
5960           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5961         enddo
5962       enddo
5963       esccorr=-eij*ekl
5964       return
5965       end
5966 c------------------------------------------------------------------------------
5967       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5968 C This subroutine calculates multi-body contributions to hydrogen-bonding
5969       implicit real*8 (a-h,o-z)
5970       include 'DIMENSIONS'
5971       include 'COMMON.IOUNITS'
5972 #ifdef MPI
5973       include "mpif.h"
5974       parameter (max_cont=maxconts)
5975       parameter (max_dim=26)
5976       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5977       double precision zapas(max_dim,maxconts,max_fg_procs),
5978      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5979       common /przechowalnia/ zapas
5980       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5981      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5982 #endif
5983       include 'COMMON.SETUP'
5984       include 'COMMON.FFIELD'
5985       include 'COMMON.DERIV'
5986       include 'COMMON.INTERACT'
5987       include 'COMMON.CONTACTS'
5988       include 'COMMON.CONTROL'
5989       include 'COMMON.LOCAL'
5990       double precision gx(3),gx1(3),time00
5991       logical lprn,ldone
5992
5993 C Set lprn=.true. for debugging
5994       lprn=.false.
5995 #ifdef MPI
5996       n_corr=0
5997       n_corr1=0
5998       if (nfgtasks.le.1) goto 30
5999       if (lprn) then
6000         write (iout,'(a)') 'Contact function values before RECEIVE:'
6001         do i=nnt,nct-2
6002           write (iout,'(2i3,50(1x,i2,f5.2))')
6003      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6004      &    j=1,num_cont_hb(i))
6005         enddo
6006       endif
6007       call flush(iout)
6008       do i=1,ntask_cont_from
6009         ncont_recv(i)=0
6010       enddo
6011       do i=1,ntask_cont_to
6012         ncont_sent(i)=0
6013       enddo
6014 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6015 c     & ntask_cont_to
6016 C Make the list of contacts to send to send to other procesors
6017 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6018 c      call flush(iout)
6019       do i=iturn3_start,iturn3_end
6020 c        write (iout,*) "make contact list turn3",i," num_cont",
6021 c     &    num_cont_hb(i)
6022         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6023       enddo
6024       do i=iturn4_start,iturn4_end
6025 c        write (iout,*) "make contact list turn4",i," num_cont",
6026 c     &   num_cont_hb(i)
6027         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6028       enddo
6029       do ii=1,nat_sent
6030         i=iat_sent(ii)
6031 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6032 c     &    num_cont_hb(i)
6033         do j=1,num_cont_hb(i)
6034         do k=1,4
6035           jjc=jcont_hb(j,i)
6036           iproc=iint_sent_local(k,jjc,ii)
6037 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6038           if (iproc.gt.0) then
6039             ncont_sent(iproc)=ncont_sent(iproc)+1
6040             nn=ncont_sent(iproc)
6041             zapas(1,nn,iproc)=i
6042             zapas(2,nn,iproc)=jjc
6043             zapas(3,nn,iproc)=facont_hb(j,i)
6044             zapas(4,nn,iproc)=ees0p(j,i)
6045             zapas(5,nn,iproc)=ees0m(j,i)
6046             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6047             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6048             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6049             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6050             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6051             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6052             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6053             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6054             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6055             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6056             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6057             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6058             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6059             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6060             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6061             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6062             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6063             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6064             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6065             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6066             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6067           endif
6068         enddo
6069         enddo
6070       enddo
6071       if (lprn) then
6072       write (iout,*)
6073      &  "Numbers of contacts to be sent to other processors",
6074      &  (ncont_sent(i),i=1,ntask_cont_to)
6075       write (iout,*) "Contacts sent"
6076       do ii=1,ntask_cont_to
6077         nn=ncont_sent(ii)
6078         iproc=itask_cont_to(ii)
6079         write (iout,*) nn," contacts to processor",iproc,
6080      &   " of CONT_TO_COMM group"
6081         do i=1,nn
6082           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6083         enddo
6084       enddo
6085       call flush(iout)
6086       endif
6087       CorrelType=477
6088       CorrelID=fg_rank+1
6089       CorrelType1=478
6090       CorrelID1=nfgtasks+fg_rank+1
6091       ireq=0
6092 C Receive the numbers of needed contacts from other processors
6093       do ii=1,ntask_cont_from
6094         iproc=itask_cont_from(ii)
6095         ireq=ireq+1
6096         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6097      &    FG_COMM,req(ireq),IERR)
6098       enddo
6099 c      write (iout,*) "IRECV ended"
6100 c      call flush(iout)
6101 C Send the number of contacts needed by other processors
6102       do ii=1,ntask_cont_to
6103         iproc=itask_cont_to(ii)
6104         ireq=ireq+1
6105         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6106      &    FG_COMM,req(ireq),IERR)
6107       enddo
6108 c      write (iout,*) "ISEND ended"
6109 c      write (iout,*) "number of requests (nn)",ireq
6110       call flush(iout)
6111       if (ireq.gt.0)
6112      &  call MPI_Waitall(ireq,req,status_array,ierr)
6113 c      write (iout,*)
6114 c     &  "Numbers of contacts to be received from other processors",
6115 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6116 c      call flush(iout)
6117 C Receive contacts
6118       ireq=0
6119       do ii=1,ntask_cont_from
6120         iproc=itask_cont_from(ii)
6121         nn=ncont_recv(ii)
6122 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6123 c     &   " of CONT_TO_COMM group"
6124         call flush(iout)
6125         if (nn.gt.0) then
6126           ireq=ireq+1
6127           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6128      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6129 c          write (iout,*) "ireq,req",ireq,req(ireq)
6130         endif
6131       enddo
6132 C Send the contacts to processors that need them
6133       do ii=1,ntask_cont_to
6134         iproc=itask_cont_to(ii)
6135         nn=ncont_sent(ii)
6136 c        write (iout,*) nn," contacts to processor",iproc,
6137 c     &   " of CONT_TO_COMM group"
6138         if (nn.gt.0) then
6139           ireq=ireq+1
6140           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6141      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6142 c          write (iout,*) "ireq,req",ireq,req(ireq)
6143 c          do i=1,nn
6144 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6145 c          enddo
6146         endif
6147       enddo
6148 c      write (iout,*) "number of requests (contacts)",ireq
6149 c      write (iout,*) "req",(req(i),i=1,4)
6150 c      call flush(iout)
6151       if (ireq.gt.0)
6152      & call MPI_Waitall(ireq,req,status_array,ierr)
6153       do iii=1,ntask_cont_from
6154         iproc=itask_cont_from(iii)
6155         nn=ncont_recv(iii)
6156         if (lprn) then
6157         write (iout,*) "Received",nn," contacts from processor",iproc,
6158      &   " of CONT_FROM_COMM group"
6159         call flush(iout)
6160         do i=1,nn
6161           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6162         enddo
6163         call flush(iout)
6164         endif
6165         do i=1,nn
6166           ii=zapas_recv(1,i,iii)
6167 c Flag the received contacts to prevent double-counting
6168           jj=-zapas_recv(2,i,iii)
6169 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6170 c          call flush(iout)
6171           nnn=num_cont_hb(ii)+1
6172           num_cont_hb(ii)=nnn
6173           jcont_hb(nnn,ii)=jj
6174           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6175           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6176           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6177           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6178           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6179           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6180           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6181           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6182           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6183           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6184           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6185           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6186           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6187           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6188           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6189           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6190           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6191           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6192           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6193           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6194           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6195           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6196           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6197           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6198         enddo
6199       enddo
6200       call flush(iout)
6201       if (lprn) then
6202         write (iout,'(a)') 'Contact function values after receive:'
6203         do i=nnt,nct-2
6204           write (iout,'(2i3,50(1x,i3,f5.2))')
6205      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6206      &    j=1,num_cont_hb(i))
6207         enddo
6208         call flush(iout)
6209       endif
6210    30 continue
6211 #endif
6212       if (lprn) then
6213         write (iout,'(a)') 'Contact function values:'
6214         do i=nnt,nct-2
6215           write (iout,'(2i3,50(1x,i3,f5.2))')
6216      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6217      &    j=1,num_cont_hb(i))
6218         enddo
6219       endif
6220       ecorr=0.0D0
6221 C Remove the loop below after debugging !!!
6222       do i=nnt,nct
6223         do j=1,3
6224           gradcorr(j,i)=0.0D0
6225           gradxorr(j,i)=0.0D0
6226         enddo
6227       enddo
6228 C Calculate the local-electrostatic correlation terms
6229       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6230         i1=i+1
6231         num_conti=num_cont_hb(i)
6232         num_conti1=num_cont_hb(i+1)
6233         do jj=1,num_conti
6234           j=jcont_hb(jj,i)
6235           jp=iabs(j)
6236           do kk=1,num_conti1
6237             j1=jcont_hb(kk,i1)
6238             jp1=iabs(j1)
6239 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6240 c     &         ' jj=',jj,' kk=',kk
6241             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6242      &          .or. j.lt.0 .and. j1.gt.0) .and.
6243      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6244 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6245 C The system gains extra energy.
6246               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6247               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6248      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6249               n_corr=n_corr+1
6250             else if (j1.eq.j) then
6251 C Contacts I-J and I-(J+1) occur simultaneously.
6252 C The system loses extra energy.
6253 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6254             endif
6255           enddo ! kk
6256           do kk=1,num_conti
6257             j1=jcont_hb(kk,i)
6258 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6259 c    &         ' jj=',jj,' kk=',kk
6260             if (j1.eq.j+1) then
6261 C Contacts I-J and (I+1)-J occur simultaneously.
6262 C The system loses extra energy.
6263 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6264             endif ! j1==j+1
6265           enddo ! kk
6266         enddo ! jj
6267       enddo ! i
6268       return
6269       end
6270 c------------------------------------------------------------------------------
6271       subroutine add_hb_contact(ii,jj,itask)
6272       implicit real*8 (a-h,o-z)
6273       include "DIMENSIONS"
6274       include "COMMON.IOUNITS"
6275       integer max_cont
6276       integer max_dim
6277       parameter (max_cont=maxconts)
6278       parameter (max_dim=26)
6279       include "COMMON.CONTACTS"
6280       double precision zapas(max_dim,maxconts,max_fg_procs),
6281      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6282       common /przechowalnia/ zapas
6283       integer i,j,ii,jj,iproc,itask(4),nn
6284 c      write (iout,*) "itask",itask
6285       do i=1,2
6286         iproc=itask(i)
6287         if (iproc.gt.0) then
6288           do j=1,num_cont_hb(ii)
6289             jjc=jcont_hb(j,ii)
6290 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6291             if (jjc.eq.jj) then
6292               ncont_sent(iproc)=ncont_sent(iproc)+1
6293               nn=ncont_sent(iproc)
6294               zapas(1,nn,iproc)=ii
6295               zapas(2,nn,iproc)=jjc
6296               zapas(3,nn,iproc)=facont_hb(j,ii)
6297               zapas(4,nn,iproc)=ees0p(j,ii)
6298               zapas(5,nn,iproc)=ees0m(j,ii)
6299               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6300               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6301               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6302               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6303               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6304               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6305               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6306               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6307               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6308               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6309               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6310               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6311               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6312               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6313               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6314               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6315               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6316               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6317               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6318               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6319               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6320               exit
6321             endif
6322           enddo
6323         endif
6324       enddo
6325       return
6326       end
6327 c------------------------------------------------------------------------------
6328       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6329      &  n_corr1)
6330 C This subroutine calculates multi-body contributions to hydrogen-bonding
6331       implicit real*8 (a-h,o-z)
6332       include 'DIMENSIONS'
6333       include 'COMMON.IOUNITS'
6334 #ifdef MPI
6335       include "mpif.h"
6336       parameter (max_cont=maxconts)
6337       parameter (max_dim=70)
6338       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6339       double precision zapas(max_dim,maxconts,max_fg_procs),
6340      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6341       common /przechowalnia/ zapas
6342       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6343      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6344 #endif
6345       include 'COMMON.SETUP'
6346       include 'COMMON.FFIELD'
6347       include 'COMMON.DERIV'
6348       include 'COMMON.LOCAL'
6349       include 'COMMON.INTERACT'
6350       include 'COMMON.CONTACTS'
6351       include 'COMMON.CHAIN'
6352       include 'COMMON.CONTROL'
6353       double precision gx(3),gx1(3)
6354       integer num_cont_hb_old(maxres)
6355       logical lprn,ldone
6356       double precision eello4,eello5,eelo6,eello_turn6
6357       external eello4,eello5,eello6,eello_turn6
6358 C Set lprn=.true. for debugging
6359       lprn=.false.
6360       eturn6=0.0d0
6361 #ifdef MPI
6362       do i=1,nres
6363         num_cont_hb_old(i)=num_cont_hb(i)
6364       enddo
6365       n_corr=0
6366       n_corr1=0
6367       if (nfgtasks.le.1) goto 30
6368       if (lprn) then
6369         write (iout,'(a)') 'Contact function values before RECEIVE:'
6370         do i=nnt,nct-2
6371           write (iout,'(2i3,50(1x,i2,f5.2))')
6372      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6373      &    j=1,num_cont_hb(i))
6374         enddo
6375       endif
6376       call flush(iout)
6377       do i=1,ntask_cont_from
6378         ncont_recv(i)=0
6379       enddo
6380       do i=1,ntask_cont_to
6381         ncont_sent(i)=0
6382       enddo
6383 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6384 c     & ntask_cont_to
6385 C Make the list of contacts to send to send to other procesors
6386       do i=iturn3_start,iturn3_end
6387 c        write (iout,*) "make contact list turn3",i," num_cont",
6388 c     &    num_cont_hb(i)
6389         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6390       enddo
6391       do i=iturn4_start,iturn4_end
6392 c        write (iout,*) "make contact list turn4",i," num_cont",
6393 c     &   num_cont_hb(i)
6394         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6395       enddo
6396       do ii=1,nat_sent
6397         i=iat_sent(ii)
6398 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6399 c     &    num_cont_hb(i)
6400         do j=1,num_cont_hb(i)
6401         do k=1,4
6402           jjc=jcont_hb(j,i)
6403           iproc=iint_sent_local(k,jjc,ii)
6404 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6405           if (iproc.ne.0) then
6406             ncont_sent(iproc)=ncont_sent(iproc)+1
6407             nn=ncont_sent(iproc)
6408             zapas(1,nn,iproc)=i
6409             zapas(2,nn,iproc)=jjc
6410             zapas(3,nn,iproc)=d_cont(j,i)
6411             ind=3
6412             do kk=1,3
6413               ind=ind+1
6414               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6415             enddo
6416             do kk=1,2
6417               do ll=1,2
6418                 ind=ind+1
6419                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6420               enddo
6421             enddo
6422             do jj=1,5
6423               do kk=1,3
6424                 do ll=1,2
6425                   do mm=1,2
6426                     ind=ind+1
6427                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6428                   enddo
6429                 enddo
6430               enddo
6431             enddo
6432           endif
6433         enddo
6434         enddo
6435       enddo
6436       if (lprn) then
6437       write (iout,*)
6438      &  "Numbers of contacts to be sent to other processors",
6439      &  (ncont_sent(i),i=1,ntask_cont_to)
6440       write (iout,*) "Contacts sent"
6441       do ii=1,ntask_cont_to
6442         nn=ncont_sent(ii)
6443         iproc=itask_cont_to(ii)
6444         write (iout,*) nn," contacts to processor",iproc,
6445      &   " of CONT_TO_COMM group"
6446         do i=1,nn
6447           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6448         enddo
6449       enddo
6450       call flush(iout)
6451       endif
6452       CorrelType=477
6453       CorrelID=fg_rank+1
6454       CorrelType1=478
6455       CorrelID1=nfgtasks+fg_rank+1
6456       ireq=0
6457 C Receive the numbers of needed contacts from other processors
6458       do ii=1,ntask_cont_from
6459         iproc=itask_cont_from(ii)
6460         ireq=ireq+1
6461         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6462      &    FG_COMM,req(ireq),IERR)
6463       enddo
6464 c      write (iout,*) "IRECV ended"
6465 c      call flush(iout)
6466 C Send the number of contacts needed by other processors
6467       do ii=1,ntask_cont_to
6468         iproc=itask_cont_to(ii)
6469         ireq=ireq+1
6470         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6471      &    FG_COMM,req(ireq),IERR)
6472       enddo
6473 c      write (iout,*) "ISEND ended"
6474 c      write (iout,*) "number of requests (nn)",ireq
6475       call flush(iout)
6476       if (ireq.gt.0)
6477      &  call MPI_Waitall(ireq,req,status_array,ierr)
6478 c      write (iout,*)
6479 c     &  "Numbers of contacts to be received from other processors",
6480 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6481 c      call flush(iout)
6482 C Receive contacts
6483       ireq=0
6484       do ii=1,ntask_cont_from
6485         iproc=itask_cont_from(ii)
6486         nn=ncont_recv(ii)
6487 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6488 c     &   " of CONT_TO_COMM group"
6489         call flush(iout)
6490         if (nn.gt.0) then
6491           ireq=ireq+1
6492           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6493      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6494 c          write (iout,*) "ireq,req",ireq,req(ireq)
6495         endif
6496       enddo
6497 C Send the contacts to processors that need them
6498       do ii=1,ntask_cont_to
6499         iproc=itask_cont_to(ii)
6500         nn=ncont_sent(ii)
6501 c        write (iout,*) nn," contacts to processor",iproc,
6502 c     &   " of CONT_TO_COMM group"
6503         if (nn.gt.0) then
6504           ireq=ireq+1
6505           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6506      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6507 c          write (iout,*) "ireq,req",ireq,req(ireq)
6508 c          do i=1,nn
6509 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6510 c          enddo
6511         endif
6512       enddo
6513 c      write (iout,*) "number of requests (contacts)",ireq
6514 c      write (iout,*) "req",(req(i),i=1,4)
6515 c      call flush(iout)
6516       if (ireq.gt.0)
6517      & call MPI_Waitall(ireq,req,status_array,ierr)
6518       do iii=1,ntask_cont_from
6519         iproc=itask_cont_from(iii)
6520         nn=ncont_recv(iii)
6521         if (lprn) then
6522         write (iout,*) "Received",nn," contacts from processor",iproc,
6523      &   " of CONT_FROM_COMM group"
6524         call flush(iout)
6525         do i=1,nn
6526           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6527         enddo
6528         call flush(iout)
6529         endif
6530         do i=1,nn
6531           ii=zapas_recv(1,i,iii)
6532 c Flag the received contacts to prevent double-counting
6533           jj=-zapas_recv(2,i,iii)
6534 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6535 c          call flush(iout)
6536           nnn=num_cont_hb(ii)+1
6537           num_cont_hb(ii)=nnn
6538           jcont_hb(nnn,ii)=jj
6539           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6540           ind=3
6541           do kk=1,3
6542             ind=ind+1
6543             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6544           enddo
6545           do kk=1,2
6546             do ll=1,2
6547               ind=ind+1
6548               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6549             enddo
6550           enddo
6551           do jj=1,5
6552             do kk=1,3
6553               do ll=1,2
6554                 do mm=1,2
6555                   ind=ind+1
6556                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6557                 enddo
6558               enddo
6559             enddo
6560           enddo
6561         enddo
6562       enddo
6563       call flush(iout)
6564       if (lprn) then
6565         write (iout,'(a)') 'Contact function values after receive:'
6566         do i=nnt,nct-2
6567           write (iout,'(2i3,50(1x,i3,5f6.3))')
6568      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6569      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6570         enddo
6571         call flush(iout)
6572       endif
6573    30 continue
6574 #endif
6575       if (lprn) then
6576         write (iout,'(a)') 'Contact function values:'
6577         do i=nnt,nct-2
6578           write (iout,'(2i3,50(1x,i2,5f6.3))')
6579      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6580      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6581         enddo
6582       endif
6583       ecorr=0.0D0
6584       ecorr5=0.0d0
6585       ecorr6=0.0d0
6586 C Remove the loop below after debugging !!!
6587       do i=nnt,nct
6588         do j=1,3
6589           gradcorr(j,i)=0.0D0
6590           gradxorr(j,i)=0.0D0
6591         enddo
6592       enddo
6593 C Calculate the dipole-dipole interaction energies
6594       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6595       do i=iatel_s,iatel_e+1
6596         num_conti=num_cont_hb(i)
6597         do jj=1,num_conti
6598           j=jcont_hb(jj,i)
6599 #ifdef MOMENT
6600           call dipole(i,j,jj)
6601 #endif
6602         enddo
6603       enddo
6604       endif
6605 C Calculate the local-electrostatic correlation terms
6606 c                write (iout,*) "gradcorr5 in eello5 before loop"
6607 c                do iii=1,nres
6608 c                  write (iout,'(i5,3f10.5)')
6609 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6610 c                enddo
6611       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6612 c        write (iout,*) "corr loop i",i
6613         i1=i+1
6614         num_conti=num_cont_hb(i)
6615         num_conti1=num_cont_hb(i+1)
6616         do jj=1,num_conti
6617           j=jcont_hb(jj,i)
6618           jp=iabs(j)
6619           do kk=1,num_conti1
6620             j1=jcont_hb(kk,i1)
6621             jp1=iabs(j1)
6622 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6623 c     &         ' jj=',jj,' kk=',kk
6624 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6625             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6626      &          .or. j.lt.0 .and. j1.gt.0) .and.
6627      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6628 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6629 C The system gains extra energy.
6630               n_corr=n_corr+1
6631               sqd1=dsqrt(d_cont(jj,i))
6632               sqd2=dsqrt(d_cont(kk,i1))
6633               sred_geom = sqd1*sqd2
6634               IF (sred_geom.lt.cutoff_corr) THEN
6635                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6636      &            ekont,fprimcont)
6637 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6638 cd     &         ' jj=',jj,' kk=',kk
6639                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6640                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6641                 do l=1,3
6642                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6643                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6644                 enddo
6645                 n_corr1=n_corr1+1
6646 cd               write (iout,*) 'sred_geom=',sred_geom,
6647 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6648 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6649 cd               write (iout,*) "g_contij",g_contij
6650 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6651 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6652                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6653                 if (wcorr4.gt.0.0d0)
6654      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6655                   if (energy_dec.and.wcorr4.gt.0.0d0)
6656      1                 write (iout,'(a6,4i5,0pf7.3)')
6657      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6658 c                write (iout,*) "gradcorr5 before eello5"
6659 c                do iii=1,nres
6660 c                  write (iout,'(i5,3f10.5)')
6661 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6662 c                enddo
6663                 if (wcorr5.gt.0.0d0)
6664      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6665 c                write (iout,*) "gradcorr5 after eello5"
6666 c                do iii=1,nres
6667 c                  write (iout,'(i5,3f10.5)')
6668 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6669 c                enddo
6670                   if (energy_dec.and.wcorr5.gt.0.0d0)
6671      1                 write (iout,'(a6,4i5,0pf7.3)')
6672      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6673 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6674 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6675                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6676      &               .or. wturn6.eq.0.0d0))then
6677 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6678                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6679                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6680      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6681 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6682 cd     &            'ecorr6=',ecorr6
6683 cd                write (iout,'(4e15.5)') sred_geom,
6684 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6685 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6686 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6687                 else if (wturn6.gt.0.0d0
6688      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6689 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6690                   eturn6=eturn6+eello_turn6(i,jj,kk)
6691                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6692      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6693 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6694                 endif
6695               ENDIF
6696 1111          continue
6697             endif
6698           enddo ! kk
6699         enddo ! jj
6700       enddo ! i
6701       do i=1,nres
6702         num_cont_hb(i)=num_cont_hb_old(i)
6703       enddo
6704 c                write (iout,*) "gradcorr5 in eello5"
6705 c                do iii=1,nres
6706 c                  write (iout,'(i5,3f10.5)')
6707 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6708 c                enddo
6709       return
6710       end
6711 c------------------------------------------------------------------------------
6712       subroutine add_hb_contact_eello(ii,jj,itask)
6713       implicit real*8 (a-h,o-z)
6714       include "DIMENSIONS"
6715       include "COMMON.IOUNITS"
6716       integer max_cont
6717       integer max_dim
6718       parameter (max_cont=maxconts)
6719       parameter (max_dim=70)
6720       include "COMMON.CONTACTS"
6721       double precision zapas(max_dim,maxconts,max_fg_procs),
6722      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6723       common /przechowalnia/ zapas
6724       integer i,j,ii,jj,iproc,itask(4),nn
6725 c      write (iout,*) "itask",itask
6726       do i=1,2
6727         iproc=itask(i)
6728         if (iproc.gt.0) then
6729           do j=1,num_cont_hb(ii)
6730             jjc=jcont_hb(j,ii)
6731 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6732             if (jjc.eq.jj) then
6733               ncont_sent(iproc)=ncont_sent(iproc)+1
6734               nn=ncont_sent(iproc)
6735               zapas(1,nn,iproc)=ii
6736               zapas(2,nn,iproc)=jjc
6737               zapas(3,nn,iproc)=d_cont(j,ii)
6738               ind=3
6739               do kk=1,3
6740                 ind=ind+1
6741                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6742               enddo
6743               do kk=1,2
6744                 do ll=1,2
6745                   ind=ind+1
6746                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6747                 enddo
6748               enddo
6749               do jj=1,5
6750                 do kk=1,3
6751                   do ll=1,2
6752                     do mm=1,2
6753                       ind=ind+1
6754                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6755                     enddo
6756                   enddo
6757                 enddo
6758               enddo
6759               exit
6760             endif
6761           enddo
6762         endif
6763       enddo
6764       return
6765       end
6766 c------------------------------------------------------------------------------
6767       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6768       implicit real*8 (a-h,o-z)
6769       include 'DIMENSIONS'
6770       include 'COMMON.IOUNITS'
6771       include 'COMMON.DERIV'
6772       include 'COMMON.INTERACT'
6773       include 'COMMON.CONTACTS'
6774       double precision gx(3),gx1(3)
6775       logical lprn
6776       lprn=.false.
6777       eij=facont_hb(jj,i)
6778       ekl=facont_hb(kk,k)
6779       ees0pij=ees0p(jj,i)
6780       ees0pkl=ees0p(kk,k)
6781       ees0mij=ees0m(jj,i)
6782       ees0mkl=ees0m(kk,k)
6783       ekont=eij*ekl
6784       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6785 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6786 C Following 4 lines for diagnostics.
6787 cd    ees0pkl=0.0D0
6788 cd    ees0pij=1.0D0
6789 cd    ees0mkl=0.0D0
6790 cd    ees0mij=1.0D0
6791 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6792 c     & 'Contacts ',i,j,
6793 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6794 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6795 c     & 'gradcorr_long'
6796 C Calculate the multi-body contribution to energy.
6797 c      ecorr=ecorr+ekont*ees
6798 C Calculate multi-body contributions to the gradient.
6799       coeffpees0pij=coeffp*ees0pij
6800       coeffmees0mij=coeffm*ees0mij
6801       coeffpees0pkl=coeffp*ees0pkl
6802       coeffmees0mkl=coeffm*ees0mkl
6803       do ll=1,3
6804 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6805         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6806      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6807      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6808         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6809      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6810      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6811 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6812         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6813      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6814      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6815         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6816      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6817      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6818         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6819      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6820      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6821         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6822         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6823         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6824      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6825      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6826         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6827         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6828 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6829       enddo
6830 c      write (iout,*)
6831 cgrad      do m=i+1,j-1
6832 cgrad        do ll=1,3
6833 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6834 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6835 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6836 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6837 cgrad        enddo
6838 cgrad      enddo
6839 cgrad      do m=k+1,l-1
6840 cgrad        do ll=1,3
6841 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6842 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6843 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6844 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6845 cgrad        enddo
6846 cgrad      enddo
6847 c      write (iout,*) "ehbcorr",ekont*ees
6848       ehbcorr=ekont*ees
6849       return
6850       end
6851 #ifdef MOMENT
6852 C---------------------------------------------------------------------------
6853       subroutine dipole(i,j,jj)
6854       implicit real*8 (a-h,o-z)
6855       include 'DIMENSIONS'
6856       include 'COMMON.IOUNITS'
6857       include 'COMMON.CHAIN'
6858       include 'COMMON.FFIELD'
6859       include 'COMMON.DERIV'
6860       include 'COMMON.INTERACT'
6861       include 'COMMON.CONTACTS'
6862       include 'COMMON.TORSION'
6863       include 'COMMON.VAR'
6864       include 'COMMON.GEO'
6865       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6866      &  auxmat(2,2)
6867       iti1 = itortyp(itype(i+1))
6868       if (j.lt.nres-1) then
6869         itj1 = itortyp(itype(j+1))
6870       else
6871         itj1=ntortyp+1
6872       endif
6873       do iii=1,2
6874         dipi(iii,1)=Ub2(iii,i)
6875         dipderi(iii)=Ub2der(iii,i)
6876         dipi(iii,2)=b1(iii,iti1)
6877         dipj(iii,1)=Ub2(iii,j)
6878         dipderj(iii)=Ub2der(iii,j)
6879         dipj(iii,2)=b1(iii,itj1)
6880       enddo
6881       kkk=0
6882       do iii=1,2
6883         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6884         do jjj=1,2
6885           kkk=kkk+1
6886           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6887         enddo
6888       enddo
6889       do kkk=1,5
6890         do lll=1,3
6891           mmm=0
6892           do iii=1,2
6893             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6894      &        auxvec(1))
6895             do jjj=1,2
6896               mmm=mmm+1
6897               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6898             enddo
6899           enddo
6900         enddo
6901       enddo
6902       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6903       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6904       do iii=1,2
6905         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6906       enddo
6907       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6908       do iii=1,2
6909         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6910       enddo
6911       return
6912       end
6913 #endif
6914 C---------------------------------------------------------------------------
6915       subroutine calc_eello(i,j,k,l,jj,kk)
6916 C
6917 C This subroutine computes matrices and vectors needed to calculate
6918 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6919 C
6920       implicit real*8 (a-h,o-z)
6921       include 'DIMENSIONS'
6922       include 'COMMON.IOUNITS'
6923       include 'COMMON.CHAIN'
6924       include 'COMMON.DERIV'
6925       include 'COMMON.INTERACT'
6926       include 'COMMON.CONTACTS'
6927       include 'COMMON.TORSION'
6928       include 'COMMON.VAR'
6929       include 'COMMON.GEO'
6930       include 'COMMON.FFIELD'
6931       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6932      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6933       logical lprn
6934       common /kutas/ lprn
6935 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6936 cd     & ' jj=',jj,' kk=',kk
6937 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6938 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6939 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6940       do iii=1,2
6941         do jjj=1,2
6942           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6943           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6944         enddo
6945       enddo
6946       call transpose2(aa1(1,1),aa1t(1,1))
6947       call transpose2(aa2(1,1),aa2t(1,1))
6948       do kkk=1,5
6949         do lll=1,3
6950           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6951      &      aa1tder(1,1,lll,kkk))
6952           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6953      &      aa2tder(1,1,lll,kkk))
6954         enddo
6955       enddo
6956       if (l.eq.j+1) then
6957 C parallel orientation of the two CA-CA-CA frames.
6958         if (i.gt.1) then
6959           iti=itortyp(itype(i))
6960         else
6961           iti=ntortyp+1
6962         endif
6963         itk1=itortyp(itype(k+1))
6964         itj=itortyp(itype(j))
6965         if (l.lt.nres-1) then
6966           itl1=itortyp(itype(l+1))
6967         else
6968           itl1=ntortyp+1
6969         endif
6970 C A1 kernel(j+1) A2T
6971 cd        do iii=1,2
6972 cd          write (iout,'(3f10.5,5x,3f10.5)')
6973 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6974 cd        enddo
6975         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6976      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6977      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6978 C Following matrices are needed only for 6-th order cumulants
6979         IF (wcorr6.gt.0.0d0) THEN
6980         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6981      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6982      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6983         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6984      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6985      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6986      &   ADtEAderx(1,1,1,1,1,1))
6987         lprn=.false.
6988         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6989      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6990      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6991      &   ADtEA1derx(1,1,1,1,1,1))
6992         ENDIF
6993 C End 6-th order cumulants
6994 cd        lprn=.false.
6995 cd        if (lprn) then
6996 cd        write (2,*) 'In calc_eello6'
6997 cd        do iii=1,2
6998 cd          write (2,*) 'iii=',iii
6999 cd          do kkk=1,5
7000 cd            write (2,*) 'kkk=',kkk
7001 cd            do jjj=1,2
7002 cd              write (2,'(3(2f10.5),5x)')
7003 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7004 cd            enddo
7005 cd          enddo
7006 cd        enddo
7007 cd        endif
7008         call transpose2(EUgder(1,1,k),auxmat(1,1))
7009         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7010         call transpose2(EUg(1,1,k),auxmat(1,1))
7011         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7012         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7013         do iii=1,2
7014           do kkk=1,5
7015             do lll=1,3
7016               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7017      &          EAEAderx(1,1,lll,kkk,iii,1))
7018             enddo
7019           enddo
7020         enddo
7021 C A1T kernel(i+1) A2
7022         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7023      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7024      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7025 C Following matrices are needed only for 6-th order cumulants
7026         IF (wcorr6.gt.0.0d0) THEN
7027         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7028      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7029      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7030         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7031      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7032      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7033      &   ADtEAderx(1,1,1,1,1,2))
7034         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7035      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7036      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7037      &   ADtEA1derx(1,1,1,1,1,2))
7038         ENDIF
7039 C End 6-th order cumulants
7040         call transpose2(EUgder(1,1,l),auxmat(1,1))
7041         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7042         call transpose2(EUg(1,1,l),auxmat(1,1))
7043         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7044         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7045         do iii=1,2
7046           do kkk=1,5
7047             do lll=1,3
7048               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7049      &          EAEAderx(1,1,lll,kkk,iii,2))
7050             enddo
7051           enddo
7052         enddo
7053 C AEAb1 and AEAb2
7054 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7055 C They are needed only when the fifth- or the sixth-order cumulants are
7056 C indluded.
7057         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7058         call transpose2(AEA(1,1,1),auxmat(1,1))
7059         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7060         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7061         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7062         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7063         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7064         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7065         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7066         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7067         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7068         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7069         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7070         call transpose2(AEA(1,1,2),auxmat(1,1))
7071         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7072         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7073         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7074         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7075         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7076         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7077         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7078         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7079         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7080         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7081         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7082 C Calculate the Cartesian derivatives of the vectors.
7083         do iii=1,2
7084           do kkk=1,5
7085             do lll=1,3
7086               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7087               call matvec2(auxmat(1,1),b1(1,iti),
7088      &          AEAb1derx(1,lll,kkk,iii,1,1))
7089               call matvec2(auxmat(1,1),Ub2(1,i),
7090      &          AEAb2derx(1,lll,kkk,iii,1,1))
7091               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7092      &          AEAb1derx(1,lll,kkk,iii,2,1))
7093               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7094      &          AEAb2derx(1,lll,kkk,iii,2,1))
7095               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7096               call matvec2(auxmat(1,1),b1(1,itj),
7097      &          AEAb1derx(1,lll,kkk,iii,1,2))
7098               call matvec2(auxmat(1,1),Ub2(1,j),
7099      &          AEAb2derx(1,lll,kkk,iii,1,2))
7100               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7101      &          AEAb1derx(1,lll,kkk,iii,2,2))
7102               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7103      &          AEAb2derx(1,lll,kkk,iii,2,2))
7104             enddo
7105           enddo
7106         enddo
7107         ENDIF
7108 C End vectors
7109       else
7110 C Antiparallel orientation of the two CA-CA-CA frames.
7111         if (i.gt.1) then
7112           iti=itortyp(itype(i))
7113         else
7114           iti=ntortyp+1
7115         endif
7116         itk1=itortyp(itype(k+1))
7117         itl=itortyp(itype(l))
7118         itj=itortyp(itype(j))
7119         if (j.lt.nres-1) then
7120           itj1=itortyp(itype(j+1))
7121         else
7122           itj1=ntortyp+1
7123         endif
7124 C A2 kernel(j-1)T A1T
7125         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7126      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7127      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7128 C Following matrices are needed only for 6-th order cumulants
7129         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7130      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7131         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7132      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7133      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7134         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7135      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7136      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7137      &   ADtEAderx(1,1,1,1,1,1))
7138         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7139      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7140      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7141      &   ADtEA1derx(1,1,1,1,1,1))
7142         ENDIF
7143 C End 6-th order cumulants
7144         call transpose2(EUgder(1,1,k),auxmat(1,1))
7145         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7146         call transpose2(EUg(1,1,k),auxmat(1,1))
7147         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7148         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7149         do iii=1,2
7150           do kkk=1,5
7151             do lll=1,3
7152               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7153      &          EAEAderx(1,1,lll,kkk,iii,1))
7154             enddo
7155           enddo
7156         enddo
7157 C A2T kernel(i+1)T A1
7158         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7159      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7160      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7161 C Following matrices are needed only for 6-th order cumulants
7162         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7163      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7164         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7165      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7166      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7167         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7168      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7169      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7170      &   ADtEAderx(1,1,1,1,1,2))
7171         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7172      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7173      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7174      &   ADtEA1derx(1,1,1,1,1,2))
7175         ENDIF
7176 C End 6-th order cumulants
7177         call transpose2(EUgder(1,1,j),auxmat(1,1))
7178         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7179         call transpose2(EUg(1,1,j),auxmat(1,1))
7180         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7181         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7182         do iii=1,2
7183           do kkk=1,5
7184             do lll=1,3
7185               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7186      &          EAEAderx(1,1,lll,kkk,iii,2))
7187             enddo
7188           enddo
7189         enddo
7190 C AEAb1 and AEAb2
7191 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7192 C They are needed only when the fifth- or the sixth-order cumulants are
7193 C indluded.
7194         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7195      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7196         call transpose2(AEA(1,1,1),auxmat(1,1))
7197         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7198         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7199         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7200         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7201         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7202         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7203         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7204         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7205         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7206         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7207         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7208         call transpose2(AEA(1,1,2),auxmat(1,1))
7209         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7210         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7211         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7212         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7213         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7214         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7215         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7216         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7217         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7218         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7219         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7220 C Calculate the Cartesian derivatives of the vectors.
7221         do iii=1,2
7222           do kkk=1,5
7223             do lll=1,3
7224               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7225               call matvec2(auxmat(1,1),b1(1,iti),
7226      &          AEAb1derx(1,lll,kkk,iii,1,1))
7227               call matvec2(auxmat(1,1),Ub2(1,i),
7228      &          AEAb2derx(1,lll,kkk,iii,1,1))
7229               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7230      &          AEAb1derx(1,lll,kkk,iii,2,1))
7231               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7232      &          AEAb2derx(1,lll,kkk,iii,2,1))
7233               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7234               call matvec2(auxmat(1,1),b1(1,itl),
7235      &          AEAb1derx(1,lll,kkk,iii,1,2))
7236               call matvec2(auxmat(1,1),Ub2(1,l),
7237      &          AEAb2derx(1,lll,kkk,iii,1,2))
7238               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7239      &          AEAb1derx(1,lll,kkk,iii,2,2))
7240               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7241      &          AEAb2derx(1,lll,kkk,iii,2,2))
7242             enddo
7243           enddo
7244         enddo
7245         ENDIF
7246 C End vectors
7247       endif
7248       return
7249       end
7250 C---------------------------------------------------------------------------
7251       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7252      &  KK,KKderg,AKA,AKAderg,AKAderx)
7253       implicit none
7254       integer nderg
7255       logical transp
7256       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7257      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7258      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7259       integer iii,kkk,lll
7260       integer jjj,mmm
7261       logical lprn
7262       common /kutas/ lprn
7263       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7264       do iii=1,nderg
7265         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7266      &    AKAderg(1,1,iii))
7267       enddo
7268 cd      if (lprn) write (2,*) 'In kernel'
7269       do kkk=1,5
7270 cd        if (lprn) write (2,*) 'kkk=',kkk
7271         do lll=1,3
7272           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7273      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7274 cd          if (lprn) then
7275 cd            write (2,*) 'lll=',lll
7276 cd            write (2,*) 'iii=1'
7277 cd            do jjj=1,2
7278 cd              write (2,'(3(2f10.5),5x)')
7279 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7280 cd            enddo
7281 cd          endif
7282           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7283      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7284 cd          if (lprn) then
7285 cd            write (2,*) 'lll=',lll
7286 cd            write (2,*) 'iii=2'
7287 cd            do jjj=1,2
7288 cd              write (2,'(3(2f10.5),5x)')
7289 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7290 cd            enddo
7291 cd          endif
7292         enddo
7293       enddo
7294       return
7295       end
7296 C---------------------------------------------------------------------------
7297       double precision function eello4(i,j,k,l,jj,kk)
7298       implicit real*8 (a-h,o-z)
7299       include 'DIMENSIONS'
7300       include 'COMMON.IOUNITS'
7301       include 'COMMON.CHAIN'
7302       include 'COMMON.DERIV'
7303       include 'COMMON.INTERACT'
7304       include 'COMMON.CONTACTS'
7305       include 'COMMON.TORSION'
7306       include 'COMMON.VAR'
7307       include 'COMMON.GEO'
7308       double precision pizda(2,2),ggg1(3),ggg2(3)
7309 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7310 cd        eello4=0.0d0
7311 cd        return
7312 cd      endif
7313 cd      print *,'eello4:',i,j,k,l,jj,kk
7314 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7315 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7316 cold      eij=facont_hb(jj,i)
7317 cold      ekl=facont_hb(kk,k)
7318 cold      ekont=eij*ekl
7319       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7320 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7321       gcorr_loc(k-1)=gcorr_loc(k-1)
7322      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7323       if (l.eq.j+1) then
7324         gcorr_loc(l-1)=gcorr_loc(l-1)
7325      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7326       else
7327         gcorr_loc(j-1)=gcorr_loc(j-1)
7328      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7329       endif
7330       do iii=1,2
7331         do kkk=1,5
7332           do lll=1,3
7333             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7334      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7335 cd            derx(lll,kkk,iii)=0.0d0
7336           enddo
7337         enddo
7338       enddo
7339 cd      gcorr_loc(l-1)=0.0d0
7340 cd      gcorr_loc(j-1)=0.0d0
7341 cd      gcorr_loc(k-1)=0.0d0
7342 cd      eel4=1.0d0
7343 cd      write (iout,*)'Contacts have occurred for peptide groups',
7344 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7345 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7346       if (j.lt.nres-1) then
7347         j1=j+1
7348         j2=j-1
7349       else
7350         j1=j-1
7351         j2=j-2
7352       endif
7353       if (l.lt.nres-1) then
7354         l1=l+1
7355         l2=l-1
7356       else
7357         l1=l-1
7358         l2=l-2
7359       endif
7360       do ll=1,3
7361 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7362 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7363         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7364         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7365 cgrad        ghalf=0.5d0*ggg1(ll)
7366         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7367         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7368         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7369         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7370         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7371         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7372 cgrad        ghalf=0.5d0*ggg2(ll)
7373         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7374         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7375         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7376         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7377         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7378         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7379       enddo
7380 cgrad      do m=i+1,j-1
7381 cgrad        do ll=1,3
7382 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7383 cgrad        enddo
7384 cgrad      enddo
7385 cgrad      do m=k+1,l-1
7386 cgrad        do ll=1,3
7387 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7388 cgrad        enddo
7389 cgrad      enddo
7390 cgrad      do m=i+2,j2
7391 cgrad        do ll=1,3
7392 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7393 cgrad        enddo
7394 cgrad      enddo
7395 cgrad      do m=k+2,l2
7396 cgrad        do ll=1,3
7397 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7398 cgrad        enddo
7399 cgrad      enddo
7400 cd      do iii=1,nres-3
7401 cd        write (2,*) iii,gcorr_loc(iii)
7402 cd      enddo
7403       eello4=ekont*eel4
7404 cd      write (2,*) 'ekont',ekont
7405 cd      write (iout,*) 'eello4',ekont*eel4
7406       return
7407       end
7408 C---------------------------------------------------------------------------
7409       double precision function eello5(i,j,k,l,jj,kk)
7410       implicit real*8 (a-h,o-z)
7411       include 'DIMENSIONS'
7412       include 'COMMON.IOUNITS'
7413       include 'COMMON.CHAIN'
7414       include 'COMMON.DERIV'
7415       include 'COMMON.INTERACT'
7416       include 'COMMON.CONTACTS'
7417       include 'COMMON.TORSION'
7418       include 'COMMON.VAR'
7419       include 'COMMON.GEO'
7420       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7421       double precision ggg1(3),ggg2(3)
7422 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7423 C                                                                              C
7424 C                            Parallel chains                                   C
7425 C                                                                              C
7426 C          o             o                   o             o                   C
7427 C         /l\           / \             \   / \           / \   /              C
7428 C        /   \         /   \             \ /   \         /   \ /               C
7429 C       j| o |l1       | o |              o| o |         | o |o                C
7430 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7431 C      \i/   \         /   \ /             /   \         /   \                 C
7432 C       o    k1             o                                                  C
7433 C         (I)          (II)                (III)          (IV)                 C
7434 C                                                                              C
7435 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7436 C                                                                              C
7437 C                            Antiparallel chains                               C
7438 C                                                                              C
7439 C          o             o                   o             o                   C
7440 C         /j\           / \             \   / \           / \   /              C
7441 C        /   \         /   \             \ /   \         /   \ /               C
7442 C      j1| o |l        | o |              o| o |         | o |o                C
7443 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7444 C      \i/   \         /   \ /             /   \         /   \                 C
7445 C       o     k1            o                                                  C
7446 C         (I)          (II)                (III)          (IV)                 C
7447 C                                                                              C
7448 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7449 C                                                                              C
7450 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7451 C                                                                              C
7452 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7453 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7454 cd        eello5=0.0d0
7455 cd        return
7456 cd      endif
7457 cd      write (iout,*)
7458 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7459 cd     &   ' and',k,l
7460       itk=itortyp(itype(k))
7461       itl=itortyp(itype(l))
7462       itj=itortyp(itype(j))
7463       eello5_1=0.0d0
7464       eello5_2=0.0d0
7465       eello5_3=0.0d0
7466       eello5_4=0.0d0
7467 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7468 cd     &   eel5_3_num,eel5_4_num)
7469       do iii=1,2
7470         do kkk=1,5
7471           do lll=1,3
7472             derx(lll,kkk,iii)=0.0d0
7473           enddo
7474         enddo
7475       enddo
7476 cd      eij=facont_hb(jj,i)
7477 cd      ekl=facont_hb(kk,k)
7478 cd      ekont=eij*ekl
7479 cd      write (iout,*)'Contacts have occurred for peptide groups',
7480 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7481 cd      goto 1111
7482 C Contribution from the graph I.
7483 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7484 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7485       call transpose2(EUg(1,1,k),auxmat(1,1))
7486       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7487       vv(1)=pizda(1,1)-pizda(2,2)
7488       vv(2)=pizda(1,2)+pizda(2,1)
7489       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7490      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7491 C Explicit gradient in virtual-dihedral angles.
7492       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7493      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7494      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7495       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7496       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7497       vv(1)=pizda(1,1)-pizda(2,2)
7498       vv(2)=pizda(1,2)+pizda(2,1)
7499       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7500      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7501      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7502       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7503       vv(1)=pizda(1,1)-pizda(2,2)
7504       vv(2)=pizda(1,2)+pizda(2,1)
7505       if (l.eq.j+1) then
7506         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7507      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7508      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7509       else
7510         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7511      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7512      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7513       endif
7514 C Cartesian gradient
7515       do iii=1,2
7516         do kkk=1,5
7517           do lll=1,3
7518             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7519      &        pizda(1,1))
7520             vv(1)=pizda(1,1)-pizda(2,2)
7521             vv(2)=pizda(1,2)+pizda(2,1)
7522             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7523      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7524      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7525           enddo
7526         enddo
7527       enddo
7528 c      goto 1112
7529 c1111  continue
7530 C Contribution from graph II
7531       call transpose2(EE(1,1,itk),auxmat(1,1))
7532       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7533       vv(1)=pizda(1,1)+pizda(2,2)
7534       vv(2)=pizda(2,1)-pizda(1,2)
7535       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7536      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7537 C Explicit gradient in virtual-dihedral angles.
7538       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7539      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7540       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7541       vv(1)=pizda(1,1)+pizda(2,2)
7542       vv(2)=pizda(2,1)-pizda(1,2)
7543       if (l.eq.j+1) then
7544         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7545      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7546      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7547       else
7548         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7549      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7550      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7551       endif
7552 C Cartesian gradient
7553       do iii=1,2
7554         do kkk=1,5
7555           do lll=1,3
7556             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7557      &        pizda(1,1))
7558             vv(1)=pizda(1,1)+pizda(2,2)
7559             vv(2)=pizda(2,1)-pizda(1,2)
7560             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7561      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7562      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7563           enddo
7564         enddo
7565       enddo
7566 cd      goto 1112
7567 cd1111  continue
7568       if (l.eq.j+1) then
7569 cd        goto 1110
7570 C Parallel orientation
7571 C Contribution from graph III
7572         call transpose2(EUg(1,1,l),auxmat(1,1))
7573         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7574         vv(1)=pizda(1,1)-pizda(2,2)
7575         vv(2)=pizda(1,2)+pizda(2,1)
7576         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7577      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7578 C Explicit gradient in virtual-dihedral angles.
7579         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7580      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7581      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7582         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7583         vv(1)=pizda(1,1)-pizda(2,2)
7584         vv(2)=pizda(1,2)+pizda(2,1)
7585         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7586      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7587      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7588         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7589         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7590         vv(1)=pizda(1,1)-pizda(2,2)
7591         vv(2)=pizda(1,2)+pizda(2,1)
7592         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7593      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7594      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7595 C Cartesian gradient
7596         do iii=1,2
7597           do kkk=1,5
7598             do lll=1,3
7599               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7600      &          pizda(1,1))
7601               vv(1)=pizda(1,1)-pizda(2,2)
7602               vv(2)=pizda(1,2)+pizda(2,1)
7603               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7604      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7605      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7606             enddo
7607           enddo
7608         enddo
7609 cd        goto 1112
7610 C Contribution from graph IV
7611 cd1110    continue
7612         call transpose2(EE(1,1,itl),auxmat(1,1))
7613         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7614         vv(1)=pizda(1,1)+pizda(2,2)
7615         vv(2)=pizda(2,1)-pizda(1,2)
7616         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7617      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7618 C Explicit gradient in virtual-dihedral angles.
7619         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7620      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7621         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7622         vv(1)=pizda(1,1)+pizda(2,2)
7623         vv(2)=pizda(2,1)-pizda(1,2)
7624         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7625      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7626      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7627 C Cartesian gradient
7628         do iii=1,2
7629           do kkk=1,5
7630             do lll=1,3
7631               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7632      &          pizda(1,1))
7633               vv(1)=pizda(1,1)+pizda(2,2)
7634               vv(2)=pizda(2,1)-pizda(1,2)
7635               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7636      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7637      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7638             enddo
7639           enddo
7640         enddo
7641       else
7642 C Antiparallel orientation
7643 C Contribution from graph III
7644 c        goto 1110
7645         call transpose2(EUg(1,1,j),auxmat(1,1))
7646         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7647         vv(1)=pizda(1,1)-pizda(2,2)
7648         vv(2)=pizda(1,2)+pizda(2,1)
7649         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7650      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7651 C Explicit gradient in virtual-dihedral angles.
7652         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7653      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7654      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7655         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7656         vv(1)=pizda(1,1)-pizda(2,2)
7657         vv(2)=pizda(1,2)+pizda(2,1)
7658         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7659      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7660      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7661         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7662         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7663         vv(1)=pizda(1,1)-pizda(2,2)
7664         vv(2)=pizda(1,2)+pizda(2,1)
7665         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7666      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7667      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7668 C Cartesian gradient
7669         do iii=1,2
7670           do kkk=1,5
7671             do lll=1,3
7672               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7673      &          pizda(1,1))
7674               vv(1)=pizda(1,1)-pizda(2,2)
7675               vv(2)=pizda(1,2)+pizda(2,1)
7676               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7677      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7678      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7679             enddo
7680           enddo
7681         enddo
7682 cd        goto 1112
7683 C Contribution from graph IV
7684 1110    continue
7685         call transpose2(EE(1,1,itj),auxmat(1,1))
7686         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7687         vv(1)=pizda(1,1)+pizda(2,2)
7688         vv(2)=pizda(2,1)-pizda(1,2)
7689         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7690      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7691 C Explicit gradient in virtual-dihedral angles.
7692         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7693      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7694         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7695         vv(1)=pizda(1,1)+pizda(2,2)
7696         vv(2)=pizda(2,1)-pizda(1,2)
7697         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7698      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7699      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7700 C Cartesian gradient
7701         do iii=1,2
7702           do kkk=1,5
7703             do lll=1,3
7704               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7705      &          pizda(1,1))
7706               vv(1)=pizda(1,1)+pizda(2,2)
7707               vv(2)=pizda(2,1)-pizda(1,2)
7708               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7709      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7710      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7711             enddo
7712           enddo
7713         enddo
7714       endif
7715 1112  continue
7716       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7717 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7718 cd        write (2,*) 'ijkl',i,j,k,l
7719 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7720 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7721 cd      endif
7722 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7723 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7724 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7725 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7726       if (j.lt.nres-1) then
7727         j1=j+1
7728         j2=j-1
7729       else
7730         j1=j-1
7731         j2=j-2
7732       endif
7733       if (l.lt.nres-1) then
7734         l1=l+1
7735         l2=l-1
7736       else
7737         l1=l-1
7738         l2=l-2
7739       endif
7740 cd      eij=1.0d0
7741 cd      ekl=1.0d0
7742 cd      ekont=1.0d0
7743 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7744 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7745 C        summed up outside the subrouine as for the other subroutines
7746 C        handling long-range interactions. The old code is commented out
7747 C        with "cgrad" to keep track of changes.
7748       do ll=1,3
7749 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7750 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7751         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7752         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7753 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7754 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7755 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7756 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7757 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7758 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7759 c     &   gradcorr5ij,
7760 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7761 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7762 cgrad        ghalf=0.5d0*ggg1(ll)
7763 cd        ghalf=0.0d0
7764         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7765         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7766         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7767         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7768         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7769         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7770 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7771 cgrad        ghalf=0.5d0*ggg2(ll)
7772 cd        ghalf=0.0d0
7773         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7774         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7775         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7776         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7777         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7778         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7779       enddo
7780 cd      goto 1112
7781 cgrad      do m=i+1,j-1
7782 cgrad        do ll=1,3
7783 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7784 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7785 cgrad        enddo
7786 cgrad      enddo
7787 cgrad      do m=k+1,l-1
7788 cgrad        do ll=1,3
7789 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7790 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7791 cgrad        enddo
7792 cgrad      enddo
7793 c1112  continue
7794 cgrad      do m=i+2,j2
7795 cgrad        do ll=1,3
7796 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7797 cgrad        enddo
7798 cgrad      enddo
7799 cgrad      do m=k+2,l2
7800 cgrad        do ll=1,3
7801 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7802 cgrad        enddo
7803 cgrad      enddo
7804 cd      do iii=1,nres-3
7805 cd        write (2,*) iii,g_corr5_loc(iii)
7806 cd      enddo
7807       eello5=ekont*eel5
7808 cd      write (2,*) 'ekont',ekont
7809 cd      write (iout,*) 'eello5',ekont*eel5
7810       return
7811       end
7812 c--------------------------------------------------------------------------
7813       double precision function eello6(i,j,k,l,jj,kk)
7814       implicit real*8 (a-h,o-z)
7815       include 'DIMENSIONS'
7816       include 'COMMON.IOUNITS'
7817       include 'COMMON.CHAIN'
7818       include 'COMMON.DERIV'
7819       include 'COMMON.INTERACT'
7820       include 'COMMON.CONTACTS'
7821       include 'COMMON.TORSION'
7822       include 'COMMON.VAR'
7823       include 'COMMON.GEO'
7824       include 'COMMON.FFIELD'
7825       double precision ggg1(3),ggg2(3)
7826 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7827 cd        eello6=0.0d0
7828 cd        return
7829 cd      endif
7830 cd      write (iout,*)
7831 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7832 cd     &   ' and',k,l
7833       eello6_1=0.0d0
7834       eello6_2=0.0d0
7835       eello6_3=0.0d0
7836       eello6_4=0.0d0
7837       eello6_5=0.0d0
7838       eello6_6=0.0d0
7839 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7840 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7841       do iii=1,2
7842         do kkk=1,5
7843           do lll=1,3
7844             derx(lll,kkk,iii)=0.0d0
7845           enddo
7846         enddo
7847       enddo
7848 cd      eij=facont_hb(jj,i)
7849 cd      ekl=facont_hb(kk,k)
7850 cd      ekont=eij*ekl
7851 cd      eij=1.0d0
7852 cd      ekl=1.0d0
7853 cd      ekont=1.0d0
7854       if (l.eq.j+1) then
7855         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7856         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7857         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7858         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7859         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7860         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7861       else
7862         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7863         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7864         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7865         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7866         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7867           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7868         else
7869           eello6_5=0.0d0
7870         endif
7871         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7872       endif
7873 C If turn contributions are considered, they will be handled separately.
7874       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7875 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7876 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7877 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7878 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7879 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7880 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7881 cd      goto 1112
7882       if (j.lt.nres-1) then
7883         j1=j+1
7884         j2=j-1
7885       else
7886         j1=j-1
7887         j2=j-2
7888       endif
7889       if (l.lt.nres-1) then
7890         l1=l+1
7891         l2=l-1
7892       else
7893         l1=l-1
7894         l2=l-2
7895       endif
7896       do ll=1,3
7897 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7898 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7899 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7900 cgrad        ghalf=0.5d0*ggg1(ll)
7901 cd        ghalf=0.0d0
7902         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7903         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7904         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7905         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7906         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7907         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7908         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7909         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7910 cgrad        ghalf=0.5d0*ggg2(ll)
7911 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7912 cd        ghalf=0.0d0
7913         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7914         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7915         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7916         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7917         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7918         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7919       enddo
7920 cd      goto 1112
7921 cgrad      do m=i+1,j-1
7922 cgrad        do ll=1,3
7923 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7924 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7925 cgrad        enddo
7926 cgrad      enddo
7927 cgrad      do m=k+1,l-1
7928 cgrad        do ll=1,3
7929 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7930 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7931 cgrad        enddo
7932 cgrad      enddo
7933 cgrad1112  continue
7934 cgrad      do m=i+2,j2
7935 cgrad        do ll=1,3
7936 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7937 cgrad        enddo
7938 cgrad      enddo
7939 cgrad      do m=k+2,l2
7940 cgrad        do ll=1,3
7941 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7942 cgrad        enddo
7943 cgrad      enddo
7944 cd      do iii=1,nres-3
7945 cd        write (2,*) iii,g_corr6_loc(iii)
7946 cd      enddo
7947       eello6=ekont*eel6
7948 cd      write (2,*) 'ekont',ekont
7949 cd      write (iout,*) 'eello6',ekont*eel6
7950       return
7951       end
7952 c--------------------------------------------------------------------------
7953       double precision function eello6_graph1(i,j,k,l,imat,swap)
7954       implicit real*8 (a-h,o-z)
7955       include 'DIMENSIONS'
7956       include 'COMMON.IOUNITS'
7957       include 'COMMON.CHAIN'
7958       include 'COMMON.DERIV'
7959       include 'COMMON.INTERACT'
7960       include 'COMMON.CONTACTS'
7961       include 'COMMON.TORSION'
7962       include 'COMMON.VAR'
7963       include 'COMMON.GEO'
7964       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7965       logical swap
7966       logical lprn
7967       common /kutas/ lprn
7968 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7969 C                                                                              C
7970 C      Parallel       Antiparallel                                             C
7971 C                                                                              C
7972 C          o             o                                                     C
7973 C         /l\           /j\                                                    C
7974 C        /   \         /   \                                                   C
7975 C       /| o |         | o |\                                                  C
7976 C     \ j|/k\|  /   \  |/k\|l /                                                C
7977 C      \ /   \ /     \ /   \ /                                                 C
7978 C       o     o       o     o                                                  C
7979 C       i             i                                                        C
7980 C                                                                              C
7981 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7982       itk=itortyp(itype(k))
7983       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7984       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7985       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7986       call transpose2(EUgC(1,1,k),auxmat(1,1))
7987       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7988       vv1(1)=pizda1(1,1)-pizda1(2,2)
7989       vv1(2)=pizda1(1,2)+pizda1(2,1)
7990       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7991       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7992       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7993       s5=scalar2(vv(1),Dtobr2(1,i))
7994 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7995       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7996       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7997      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7998      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7999      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8000      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8001      & +scalar2(vv(1),Dtobr2der(1,i)))
8002       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8003       vv1(1)=pizda1(1,1)-pizda1(2,2)
8004       vv1(2)=pizda1(1,2)+pizda1(2,1)
8005       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8006       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8007       if (l.eq.j+1) then
8008         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8009      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8010      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8011      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8012      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8013       else
8014         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8015      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8016      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8017      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8018      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8019       endif
8020       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8021       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8022       vv1(1)=pizda1(1,1)-pizda1(2,2)
8023       vv1(2)=pizda1(1,2)+pizda1(2,1)
8024       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8025      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8026      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8027      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8028       do iii=1,2
8029         if (swap) then
8030           ind=3-iii
8031         else
8032           ind=iii
8033         endif
8034         do kkk=1,5
8035           do lll=1,3
8036             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8037             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8038             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8039             call transpose2(EUgC(1,1,k),auxmat(1,1))
8040             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8041      &        pizda1(1,1))
8042             vv1(1)=pizda1(1,1)-pizda1(2,2)
8043             vv1(2)=pizda1(1,2)+pizda1(2,1)
8044             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8045             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8046      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8047             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8048      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8049             s5=scalar2(vv(1),Dtobr2(1,i))
8050             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8051           enddo
8052         enddo
8053       enddo
8054       return
8055       end
8056 c----------------------------------------------------------------------------
8057       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8058       implicit real*8 (a-h,o-z)
8059       include 'DIMENSIONS'
8060       include 'COMMON.IOUNITS'
8061       include 'COMMON.CHAIN'
8062       include 'COMMON.DERIV'
8063       include 'COMMON.INTERACT'
8064       include 'COMMON.CONTACTS'
8065       include 'COMMON.TORSION'
8066       include 'COMMON.VAR'
8067       include 'COMMON.GEO'
8068       logical swap
8069       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8070      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8071       logical lprn
8072       common /kutas/ lprn
8073 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8074 C                                                                              C
8075 C      Parallel       Antiparallel                                             C
8076 C                                                                              C
8077 C          o             o                                                     C
8078 C     \   /l\           /j\   /                                                C
8079 C      \ /   \         /   \ /                                                 C
8080 C       o| o |         | o |o                                                  C
8081 C     \ j|/k\|      \  |/k\|l                                                  C
8082 C      \ /   \       \ /   \                                                   C
8083 C       o             o                                                        C
8084 C       i             i                                                        C
8085 C                                                                              C
8086 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8087 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8088 C AL 7/4/01 s1 would occur in the sixth-order moment,
8089 C           but not in a cluster cumulant
8090 #ifdef MOMENT
8091       s1=dip(1,jj,i)*dip(1,kk,k)
8092 #endif
8093       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8094       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8095       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8096       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8097       call transpose2(EUg(1,1,k),auxmat(1,1))
8098       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8099       vv(1)=pizda(1,1)-pizda(2,2)
8100       vv(2)=pizda(1,2)+pizda(2,1)
8101       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8102 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8103 #ifdef MOMENT
8104       eello6_graph2=-(s1+s2+s3+s4)
8105 #else
8106       eello6_graph2=-(s2+s3+s4)
8107 #endif
8108 c      eello6_graph2=-s3
8109 C Derivatives in gamma(i-1)
8110       if (i.gt.1) then
8111 #ifdef MOMENT
8112         s1=dipderg(1,jj,i)*dip(1,kk,k)
8113 #endif
8114         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8115         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8116         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8117         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8118 #ifdef MOMENT
8119         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8120 #else
8121         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8122 #endif
8123 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8124       endif
8125 C Derivatives in gamma(k-1)
8126 #ifdef MOMENT
8127       s1=dip(1,jj,i)*dipderg(1,kk,k)
8128 #endif
8129       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8130       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8131       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8132       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8133       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8134       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8135       vv(1)=pizda(1,1)-pizda(2,2)
8136       vv(2)=pizda(1,2)+pizda(2,1)
8137       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8138 #ifdef MOMENT
8139       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8140 #else
8141       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8142 #endif
8143 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8144 C Derivatives in gamma(j-1) or gamma(l-1)
8145       if (j.gt.1) then
8146 #ifdef MOMENT
8147         s1=dipderg(3,jj,i)*dip(1,kk,k)
8148 #endif
8149         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8150         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8151         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8152         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8153         vv(1)=pizda(1,1)-pizda(2,2)
8154         vv(2)=pizda(1,2)+pizda(2,1)
8155         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8156 #ifdef MOMENT
8157         if (swap) then
8158           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8159         else
8160           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8161         endif
8162 #endif
8163         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8164 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8165       endif
8166 C Derivatives in gamma(l-1) or gamma(j-1)
8167       if (l.gt.1) then
8168 #ifdef MOMENT
8169         s1=dip(1,jj,i)*dipderg(3,kk,k)
8170 #endif
8171         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8172         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8173         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8174         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8175         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8176         vv(1)=pizda(1,1)-pizda(2,2)
8177         vv(2)=pizda(1,2)+pizda(2,1)
8178         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8179 #ifdef MOMENT
8180         if (swap) then
8181           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8182         else
8183           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8184         endif
8185 #endif
8186         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8187 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8188       endif
8189 C Cartesian derivatives.
8190       if (lprn) then
8191         write (2,*) 'In eello6_graph2'
8192         do iii=1,2
8193           write (2,*) 'iii=',iii
8194           do kkk=1,5
8195             write (2,*) 'kkk=',kkk
8196             do jjj=1,2
8197               write (2,'(3(2f10.5),5x)')
8198      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8199             enddo
8200           enddo
8201         enddo
8202       endif
8203       do iii=1,2
8204         do kkk=1,5
8205           do lll=1,3
8206 #ifdef MOMENT
8207             if (iii.eq.1) then
8208               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8209             else
8210               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8211             endif
8212 #endif
8213             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8214      &        auxvec(1))
8215             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8216             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8217      &        auxvec(1))
8218             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8219             call transpose2(EUg(1,1,k),auxmat(1,1))
8220             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8221      &        pizda(1,1))
8222             vv(1)=pizda(1,1)-pizda(2,2)
8223             vv(2)=pizda(1,2)+pizda(2,1)
8224             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8225 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8226 #ifdef MOMENT
8227             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8228 #else
8229             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8230 #endif
8231             if (swap) then
8232               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8233             else
8234               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8235             endif
8236           enddo
8237         enddo
8238       enddo
8239       return
8240       end
8241 c----------------------------------------------------------------------------
8242       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8243       implicit real*8 (a-h,o-z)
8244       include 'DIMENSIONS'
8245       include 'COMMON.IOUNITS'
8246       include 'COMMON.CHAIN'
8247       include 'COMMON.DERIV'
8248       include 'COMMON.INTERACT'
8249       include 'COMMON.CONTACTS'
8250       include 'COMMON.TORSION'
8251       include 'COMMON.VAR'
8252       include 'COMMON.GEO'
8253       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8254       logical swap
8255 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8256 C                                                                              C
8257 C      Parallel       Antiparallel                                             C
8258 C                                                                              C
8259 C          o             o                                                     C
8260 C         /l\   /   \   /j\                                                    C
8261 C        /   \ /     \ /   \                                                   C
8262 C       /| o |o       o| o |\                                                  C
8263 C       j|/k\|  /      |/k\|l /                                                C
8264 C        /   \ /       /   \ /                                                 C
8265 C       /     o       /     o                                                  C
8266 C       i             i                                                        C
8267 C                                                                              C
8268 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8269 C
8270 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8271 C           energy moment and not to the cluster cumulant.
8272       iti=itortyp(itype(i))
8273       if (j.lt.nres-1) then
8274         itj1=itortyp(itype(j+1))
8275       else
8276         itj1=ntortyp+1
8277       endif
8278       itk=itortyp(itype(k))
8279       itk1=itortyp(itype(k+1))
8280       if (l.lt.nres-1) then
8281         itl1=itortyp(itype(l+1))
8282       else
8283         itl1=ntortyp+1
8284       endif
8285 #ifdef MOMENT
8286       s1=dip(4,jj,i)*dip(4,kk,k)
8287 #endif
8288       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8289       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8290       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8291       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8292       call transpose2(EE(1,1,itk),auxmat(1,1))
8293       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8294       vv(1)=pizda(1,1)+pizda(2,2)
8295       vv(2)=pizda(2,1)-pizda(1,2)
8296       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8297 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8298 cd     & "sum",-(s2+s3+s4)
8299 #ifdef MOMENT
8300       eello6_graph3=-(s1+s2+s3+s4)
8301 #else
8302       eello6_graph3=-(s2+s3+s4)
8303 #endif
8304 c      eello6_graph3=-s4
8305 C Derivatives in gamma(k-1)
8306       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8307       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8308       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8309       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8310 C Derivatives in gamma(l-1)
8311       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8312       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8313       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8314       vv(1)=pizda(1,1)+pizda(2,2)
8315       vv(2)=pizda(2,1)-pizda(1,2)
8316       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8317       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8318 C Cartesian derivatives.
8319       do iii=1,2
8320         do kkk=1,5
8321           do lll=1,3
8322 #ifdef MOMENT
8323             if (iii.eq.1) then
8324               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8325             else
8326               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8327             endif
8328 #endif
8329             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8330      &        auxvec(1))
8331             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8332             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8333      &        auxvec(1))
8334             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8335             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8336      &        pizda(1,1))
8337             vv(1)=pizda(1,1)+pizda(2,2)
8338             vv(2)=pizda(2,1)-pizda(1,2)
8339             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8340 #ifdef MOMENT
8341             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8342 #else
8343             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8344 #endif
8345             if (swap) then
8346               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8347             else
8348               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8349             endif
8350 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8351           enddo
8352         enddo
8353       enddo
8354       return
8355       end
8356 c----------------------------------------------------------------------------
8357       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8358       implicit real*8 (a-h,o-z)
8359       include 'DIMENSIONS'
8360       include 'COMMON.IOUNITS'
8361       include 'COMMON.CHAIN'
8362       include 'COMMON.DERIV'
8363       include 'COMMON.INTERACT'
8364       include 'COMMON.CONTACTS'
8365       include 'COMMON.TORSION'
8366       include 'COMMON.VAR'
8367       include 'COMMON.GEO'
8368       include 'COMMON.FFIELD'
8369       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8370      & auxvec1(2),auxmat1(2,2)
8371       logical swap
8372 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8373 C                                                                              C
8374 C      Parallel       Antiparallel                                             C
8375 C                                                                              C
8376 C          o             o                                                     C
8377 C         /l\   /   \   /j\                                                    C
8378 C        /   \ /     \ /   \                                                   C
8379 C       /| o |o       o| o |\                                                  C
8380 C     \ j|/k\|      \  |/k\|l                                                  C
8381 C      \ /   \       \ /   \                                                   C
8382 C       o     \       o     \                                                  C
8383 C       i             i                                                        C
8384 C                                                                              C
8385 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8386 C
8387 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8388 C           energy moment and not to the cluster cumulant.
8389 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8390       iti=itortyp(itype(i))
8391       itj=itortyp(itype(j))
8392       if (j.lt.nres-1) then
8393         itj1=itortyp(itype(j+1))
8394       else
8395         itj1=ntortyp+1
8396       endif
8397       itk=itortyp(itype(k))
8398       if (k.lt.nres-1) then
8399         itk1=itortyp(itype(k+1))
8400       else
8401         itk1=ntortyp+1
8402       endif
8403       itl=itortyp(itype(l))
8404       if (l.lt.nres-1) then
8405         itl1=itortyp(itype(l+1))
8406       else
8407         itl1=ntortyp+1
8408       endif
8409 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8410 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8411 cd     & ' itl',itl,' itl1',itl1
8412 #ifdef MOMENT
8413       if (imat.eq.1) then
8414         s1=dip(3,jj,i)*dip(3,kk,k)
8415       else
8416         s1=dip(2,jj,j)*dip(2,kk,l)
8417       endif
8418 #endif
8419       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8420       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8421       if (j.eq.l+1) then
8422         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8423         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8424       else
8425         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8426         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8427       endif
8428       call transpose2(EUg(1,1,k),auxmat(1,1))
8429       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8430       vv(1)=pizda(1,1)-pizda(2,2)
8431       vv(2)=pizda(2,1)+pizda(1,2)
8432       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8433 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8434 #ifdef MOMENT
8435       eello6_graph4=-(s1+s2+s3+s4)
8436 #else
8437       eello6_graph4=-(s2+s3+s4)
8438 #endif
8439 C Derivatives in gamma(i-1)
8440       if (i.gt.1) then
8441 #ifdef MOMENT
8442         if (imat.eq.1) then
8443           s1=dipderg(2,jj,i)*dip(3,kk,k)
8444         else
8445           s1=dipderg(4,jj,j)*dip(2,kk,l)
8446         endif
8447 #endif
8448         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8449         if (j.eq.l+1) then
8450           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8451           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8452         else
8453           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8454           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8455         endif
8456         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8457         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8458 cd          write (2,*) 'turn6 derivatives'
8459 #ifdef MOMENT
8460           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8461 #else
8462           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8463 #endif
8464         else
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         endif
8471       endif
8472 C Derivatives in gamma(k-1)
8473 #ifdef MOMENT
8474       if (imat.eq.1) then
8475         s1=dip(3,jj,i)*dipderg(2,kk,k)
8476       else
8477         s1=dip(2,jj,j)*dipderg(4,kk,l)
8478       endif
8479 #endif
8480       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8481       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8482       if (j.eq.l+1) then
8483         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8484         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8485       else
8486         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8487         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8488       endif
8489       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8490       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8491       vv(1)=pizda(1,1)-pizda(2,2)
8492       vv(2)=pizda(2,1)+pizda(1,2)
8493       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8494       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8495 #ifdef MOMENT
8496         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8497 #else
8498         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8499 #endif
8500       else
8501 #ifdef MOMENT
8502         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8503 #else
8504         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8505 #endif
8506       endif
8507 C Derivatives in gamma(j-1) or gamma(l-1)
8508       if (l.eq.j+1 .and. l.gt.1) then
8509         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8510         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8511         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8512         vv(1)=pizda(1,1)-pizda(2,2)
8513         vv(2)=pizda(2,1)+pizda(1,2)
8514         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8515         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8516       else if (j.gt.1) then
8517         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8518         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8519         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8520         vv(1)=pizda(1,1)-pizda(2,2)
8521         vv(2)=pizda(2,1)+pizda(1,2)
8522         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8523         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8524           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8525         else
8526           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8527         endif
8528       endif
8529 C Cartesian derivatives.
8530       do iii=1,2
8531         do kkk=1,5
8532           do lll=1,3
8533 #ifdef MOMENT
8534             if (iii.eq.1) then
8535               if (imat.eq.1) then
8536                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8537               else
8538                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8539               endif
8540             else
8541               if (imat.eq.1) then
8542                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8543               else
8544                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8545               endif
8546             endif
8547 #endif
8548             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8549      &        auxvec(1))
8550             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8551             if (j.eq.l+1) then
8552               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8553      &          b1(1,itj1),auxvec(1))
8554               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8555             else
8556               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8557      &          b1(1,itl1),auxvec(1))
8558               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8559             endif
8560             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8561      &        pizda(1,1))
8562             vv(1)=pizda(1,1)-pizda(2,2)
8563             vv(2)=pizda(2,1)+pizda(1,2)
8564             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8565             if (swap) then
8566               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8567 #ifdef MOMENT
8568                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8569      &             -(s1+s2+s4)
8570 #else
8571                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8572      &             -(s2+s4)
8573 #endif
8574                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8575               else
8576 #ifdef MOMENT
8577                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8578 #else
8579                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8580 #endif
8581                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8582               endif
8583             else
8584 #ifdef MOMENT
8585               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8586 #else
8587               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8588 #endif
8589               if (l.eq.j+1) then
8590                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8591               else
8592                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8593               endif
8594             endif
8595           enddo
8596         enddo
8597       enddo
8598       return
8599       end
8600 c----------------------------------------------------------------------------
8601       double precision function eello_turn6(i,jj,kk)
8602       implicit real*8 (a-h,o-z)
8603       include 'DIMENSIONS'
8604       include 'COMMON.IOUNITS'
8605       include 'COMMON.CHAIN'
8606       include 'COMMON.DERIV'
8607       include 'COMMON.INTERACT'
8608       include 'COMMON.CONTACTS'
8609       include 'COMMON.TORSION'
8610       include 'COMMON.VAR'
8611       include 'COMMON.GEO'
8612       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8613      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8614      &  ggg1(3),ggg2(3)
8615       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8616      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8617 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8618 C           the respective energy moment and not to the cluster cumulant.
8619       s1=0.0d0
8620       s8=0.0d0
8621       s13=0.0d0
8622 c
8623       eello_turn6=0.0d0
8624       j=i+4
8625       k=i+1
8626       l=i+3
8627       iti=itortyp(itype(i))
8628       itk=itortyp(itype(k))
8629       itk1=itortyp(itype(k+1))
8630       itl=itortyp(itype(l))
8631       itj=itortyp(itype(j))
8632 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8633 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8634 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8635 cd        eello6=0.0d0
8636 cd        return
8637 cd      endif
8638 cd      write (iout,*)
8639 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8640 cd     &   ' and',k,l
8641 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8642       do iii=1,2
8643         do kkk=1,5
8644           do lll=1,3
8645             derx_turn(lll,kkk,iii)=0.0d0
8646           enddo
8647         enddo
8648       enddo
8649 cd      eij=1.0d0
8650 cd      ekl=1.0d0
8651 cd      ekont=1.0d0
8652       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8653 cd      eello6_5=0.0d0
8654 cd      write (2,*) 'eello6_5',eello6_5
8655 #ifdef MOMENT
8656       call transpose2(AEA(1,1,1),auxmat(1,1))
8657       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8658       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8659       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8660 #endif
8661       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8662       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8663       s2 = scalar2(b1(1,itk),vtemp1(1))
8664 #ifdef MOMENT
8665       call transpose2(AEA(1,1,2),atemp(1,1))
8666       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8667       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8668       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8669 #endif
8670       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8671       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8672       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8673 #ifdef MOMENT
8674       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8675       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8676       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8677       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8678       ss13 = scalar2(b1(1,itk),vtemp4(1))
8679       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8680 #endif
8681 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8682 c      s1=0.0d0
8683 c      s2=0.0d0
8684 c      s8=0.0d0
8685 c      s12=0.0d0
8686 c      s13=0.0d0
8687       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8688 C Derivatives in gamma(i+2)
8689       s1d =0.0d0
8690       s8d =0.0d0
8691 #ifdef MOMENT
8692       call transpose2(AEA(1,1,1),auxmatd(1,1))
8693       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8694       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8695       call transpose2(AEAderg(1,1,2),atempd(1,1))
8696       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8697       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8698 #endif
8699       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8700       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8701       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8702 c      s1d=0.0d0
8703 c      s2d=0.0d0
8704 c      s8d=0.0d0
8705 c      s12d=0.0d0
8706 c      s13d=0.0d0
8707       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8708 C Derivatives in gamma(i+3)
8709 #ifdef MOMENT
8710       call transpose2(AEA(1,1,1),auxmatd(1,1))
8711       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8712       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8713       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8714 #endif
8715       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8716       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8717       s2d = scalar2(b1(1,itk),vtemp1d(1))
8718 #ifdef MOMENT
8719       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8720       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8721 #endif
8722       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8723 #ifdef MOMENT
8724       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8725       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8726       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8727 #endif
8728 c      s1d=0.0d0
8729 c      s2d=0.0d0
8730 c      s8d=0.0d0
8731 c      s12d=0.0d0
8732 c      s13d=0.0d0
8733 #ifdef MOMENT
8734       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8735      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8736 #else
8737       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8738      &               -0.5d0*ekont*(s2d+s12d)
8739 #endif
8740 C Derivatives in gamma(i+4)
8741       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8742       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8743       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8744 #ifdef MOMENT
8745       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8746       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8747       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8748 #endif
8749 c      s1d=0.0d0
8750 c      s2d=0.0d0
8751 c      s8d=0.0d0
8752 C      s12d=0.0d0
8753 c      s13d=0.0d0
8754 #ifdef MOMENT
8755       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8756 #else
8757       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8758 #endif
8759 C Derivatives in gamma(i+5)
8760 #ifdef MOMENT
8761       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8762       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8763       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8764 #endif
8765       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8766       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8767       s2d = scalar2(b1(1,itk),vtemp1d(1))
8768 #ifdef MOMENT
8769       call transpose2(AEA(1,1,2),atempd(1,1))
8770       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8771       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8772 #endif
8773       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8774       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8775 #ifdef MOMENT
8776       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8777       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8778       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8779 #endif
8780 c      s1d=0.0d0
8781 c      s2d=0.0d0
8782 c      s8d=0.0d0
8783 c      s12d=0.0d0
8784 c      s13d=0.0d0
8785 #ifdef MOMENT
8786       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8787      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8788 #else
8789       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8790      &               -0.5d0*ekont*(s2d+s12d)
8791 #endif
8792 C Cartesian derivatives
8793       do iii=1,2
8794         do kkk=1,5
8795           do lll=1,3
8796 #ifdef MOMENT
8797             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8798             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8799             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8800 #endif
8801             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8802             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8803      &          vtemp1d(1))
8804             s2d = scalar2(b1(1,itk),vtemp1d(1))
8805 #ifdef MOMENT
8806             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8807             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8808             s8d = -(atempd(1,1)+atempd(2,2))*
8809      &           scalar2(cc(1,1,itl),vtemp2(1))
8810 #endif
8811             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8812      &           auxmatd(1,1))
8813             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8814             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8815 c      s1d=0.0d0
8816 c      s2d=0.0d0
8817 c      s8d=0.0d0
8818 c      s12d=0.0d0
8819 c      s13d=0.0d0
8820 #ifdef MOMENT
8821             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8822      &        - 0.5d0*(s1d+s2d)
8823 #else
8824             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8825      &        - 0.5d0*s2d
8826 #endif
8827 #ifdef MOMENT
8828             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8829      &        - 0.5d0*(s8d+s12d)
8830 #else
8831             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8832      &        - 0.5d0*s12d
8833 #endif
8834           enddo
8835         enddo
8836       enddo
8837 #ifdef MOMENT
8838       do kkk=1,5
8839         do lll=1,3
8840           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8841      &      achuj_tempd(1,1))
8842           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8843           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8844           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8845           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8846           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8847      &      vtemp4d(1))
8848           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8849           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8850           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8851         enddo
8852       enddo
8853 #endif
8854 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8855 cd     &  16*eel_turn6_num
8856 cd      goto 1112
8857       if (j.lt.nres-1) then
8858         j1=j+1
8859         j2=j-1
8860       else
8861         j1=j-1
8862         j2=j-2
8863       endif
8864       if (l.lt.nres-1) then
8865         l1=l+1
8866         l2=l-1
8867       else
8868         l1=l-1
8869         l2=l-2
8870       endif
8871       do ll=1,3
8872 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8873 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8874 cgrad        ghalf=0.5d0*ggg1(ll)
8875 cd        ghalf=0.0d0
8876         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8877         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8878         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8879      &    +ekont*derx_turn(ll,2,1)
8880         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8881         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8882      &    +ekont*derx_turn(ll,4,1)
8883         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8884         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8885         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8886 cgrad        ghalf=0.5d0*ggg2(ll)
8887 cd        ghalf=0.0d0
8888         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8889      &    +ekont*derx_turn(ll,2,2)
8890         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8891         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8892      &    +ekont*derx_turn(ll,4,2)
8893         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8894         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8895         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8896       enddo
8897 cd      goto 1112
8898 cgrad      do m=i+1,j-1
8899 cgrad        do ll=1,3
8900 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8901 cgrad        enddo
8902 cgrad      enddo
8903 cgrad      do m=k+1,l-1
8904 cgrad        do ll=1,3
8905 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8906 cgrad        enddo
8907 cgrad      enddo
8908 cgrad1112  continue
8909 cgrad      do m=i+2,j2
8910 cgrad        do ll=1,3
8911 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8912 cgrad        enddo
8913 cgrad      enddo
8914 cgrad      do m=k+2,l2
8915 cgrad        do ll=1,3
8916 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8917 cgrad        enddo
8918 cgrad      enddo
8919 cd      do iii=1,nres-3
8920 cd        write (2,*) iii,g_corr6_loc(iii)
8921 cd      enddo
8922       eello_turn6=ekont*eel_turn6
8923 cd      write (2,*) 'ekont',ekont
8924 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8925       return
8926       end
8927
8928 C-----------------------------------------------------------------------------
8929       double precision function scalar(u,v)
8930 !DIR$ INLINEALWAYS scalar
8931 #ifndef OSF
8932 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8933 #endif
8934       implicit none
8935       double precision u(3),v(3)
8936 cd      double precision sc
8937 cd      integer i
8938 cd      sc=0.0d0
8939 cd      do i=1,3
8940 cd        sc=sc+u(i)*v(i)
8941 cd      enddo
8942 cd      scalar=sc
8943
8944       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8945       return
8946       end
8947 crc-------------------------------------------------
8948       SUBROUTINE MATVEC2(A1,V1,V2)
8949 !DIR$ INLINEALWAYS MATVEC2
8950 #ifndef OSF
8951 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8952 #endif
8953       implicit real*8 (a-h,o-z)
8954       include 'DIMENSIONS'
8955       DIMENSION A1(2,2),V1(2),V2(2)
8956 c      DO 1 I=1,2
8957 c        VI=0.0
8958 c        DO 3 K=1,2
8959 c    3     VI=VI+A1(I,K)*V1(K)
8960 c        Vaux(I)=VI
8961 c    1 CONTINUE
8962
8963       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8964       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8965
8966       v2(1)=vaux1
8967       v2(2)=vaux2
8968       END
8969 C---------------------------------------
8970       SUBROUTINE MATMAT2(A1,A2,A3)
8971 #ifndef OSF
8972 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8973 #endif
8974       implicit real*8 (a-h,o-z)
8975       include 'DIMENSIONS'
8976       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8977 c      DIMENSION AI3(2,2)
8978 c        DO  J=1,2
8979 c          A3IJ=0.0
8980 c          DO K=1,2
8981 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8982 c          enddo
8983 c          A3(I,J)=A3IJ
8984 c       enddo
8985 c      enddo
8986
8987       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8988       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8989       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8990       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8991
8992       A3(1,1)=AI3_11
8993       A3(2,1)=AI3_21
8994       A3(1,2)=AI3_12
8995       A3(2,2)=AI3_22
8996       END
8997
8998 c-------------------------------------------------------------------------
8999       double precision function scalar2(u,v)
9000 !DIR$ INLINEALWAYS scalar2
9001       implicit none
9002       double precision u(2),v(2)
9003       double precision sc
9004       integer i
9005       scalar2=u(1)*v(1)+u(2)*v(2)
9006       return
9007       end
9008
9009 C-----------------------------------------------------------------------------
9010
9011       subroutine transpose2(a,at)
9012 !DIR$ INLINEALWAYS transpose2
9013 #ifndef OSF
9014 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9015 #endif
9016       implicit none
9017       double precision a(2,2),at(2,2)
9018       at(1,1)=a(1,1)
9019       at(1,2)=a(2,1)
9020       at(2,1)=a(1,2)
9021       at(2,2)=a(2,2)
9022       return
9023       end
9024 c--------------------------------------------------------------------------
9025       subroutine transpose(n,a,at)
9026       implicit none
9027       integer n,i,j
9028       double precision a(n,n),at(n,n)
9029       do i=1,n
9030         do j=1,n
9031           at(j,i)=a(i,j)
9032         enddo
9033       enddo
9034       return
9035       end
9036 C---------------------------------------------------------------------------
9037       subroutine prodmat3(a1,a2,kk,transp,prod)
9038 !DIR$ INLINEALWAYS prodmat3
9039 #ifndef OSF
9040 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9041 #endif
9042       implicit none
9043       integer i,j
9044       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9045       logical transp
9046 crc      double precision auxmat(2,2),prod_(2,2)
9047
9048       if (transp) then
9049 crc        call transpose2(kk(1,1),auxmat(1,1))
9050 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9051 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9052
9053            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9054      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9055            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9056      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9057            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9058      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9059            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9060      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9061
9062       else
9063 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9064 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9065
9066            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9067      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9068            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9069      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9070            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9071      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9072            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9073      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9074
9075       endif
9076 c      call transpose2(a2(1,1),a2t(1,1))
9077
9078 crc      print *,transp
9079 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9080 crc      print *,((prod(i,j),i=1,2),j=1,2)
9081
9082       return
9083       end
9084