source/unres/src_CSA/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
 127 C     JUYONG for dfa test!
 128       if (wdfa_dist.gt.0) call edfad(edfadis)
 129 c      print*, 'edfad is finished!', edfadis
 130       if (wdfa_tor.gt.0) call edfat(edfator)
 131 c      print*, 'edfat is finished!', edfator
 132       if (wdfa_nei.gt.0) call edfan(edfanei)
 133 c      print*, 'edfan is finished!', edfanei
 134       if (wdfa_beta.gt.0) call edfab(edfabet)
 135 c      print*, 'edfab is finished!', edfabet
 136 C      stop
 137 C     JUYONG
 138
 139 c      print *,"Processor",myrank," computed USCSC"
 140 #ifdef TIMING
 141       time01=MPI_Wtime()
 142 #endif
 143       call vec_and_deriv
 144 #ifdef TIMING
 145       time_vec=time_vec+MPI_Wtime()-time01
 146 #endif
 147 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 148       if (ipot.lt.6) then
 149 #ifdef SPLITELE
 150          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 151      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 152      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 153      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 154 #else
 155          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 156      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 157      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 158      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 159 #endif
 160             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 161          else
 162             ees=0.0d0
 163             evdw1=0.0d0
 164             eel_loc=0.0d0
 165             eello_turn3=0.0d0
 166             eello_turn4=0.0d0
 167          endif
 168       else
 169 c        write (iout,*) "Soft-spheer ELEC potential"
 170         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 171      &   eello_turn4)
 172       endif
 173 c      print *,"Processor",myrank," computed UELEC"
 174 C
 175 C Calculate excluded-volume interaction energy between peptide groups
 176 C and side chains.
 177 C
 178       if (ipot.lt.6) then
 179        if(wscp.gt.0d0) then
 180         call escp(evdw2,evdw2_14)
 181        else
 182         evdw2=0
 183         evdw2_14=0
 184        endif
 185       else
 186 c        write (iout,*) "Soft-sphere SCP potential"
 187         call escp_soft_sphere(evdw2,evdw2_14)
 188       endif
 189 c
 190 c Calculate the bond-stretching energy
 191 c
 192       call ebond(estr)
 193 C
 194 C Calculate the disulfide-bridge and other energy and the contributions
 195 C from other distance constraints.
 196 cd    print *,'Calling EHPB'
 197       call edis(ehpb)
 198 cd    print *,'EHPB exitted succesfully.'
 199 C
 200 C Calculate the virtual-bond-angle energy.
 201 C
 202       if (wang.gt.0d0) then
 203         call ebend(ebe)
 204       else
 205         ebe=0
 206       endif
 207 c      print *,"Processor",myrank," computed UB"
 208 C
 209 C Calculate the SC local energy.
 210 C
 211       call esc(escloc)
 212 c      print *,"Processor",myrank," computed USC"
 213 C
 214 C Calculate the virtual-bond torsional energy.
 215 C
 216 cd    print *,'nterm=',nterm
 217       if (wtor.gt.0) then
 218        call etor(etors,edihcnstr)
 219       else
 220        etors=0
 221        edihcnstr=0
 222       endif
 223 c      print *,"Processor",myrank," computed Utor"
 224 C
 225 C 6/23/01 Calculate double-torsional energy
 226 C
 227       if (wtor_d.gt.0) then
 228        call etor_d(etors_d)
 229       else
 230        etors_d=0
 231       endif
 232 c      print *,"Processor",myrank," computed Utord"
 233 C
 234 C 21/5/07 Calculate local sicdechain correlation energy
 235 C
 236       if (wsccor.gt.0.0d0) then
 237         call eback_sc_corr(esccor)
 238       else
 239         esccor=0.0d0
 240       endif
 241 c      print *,"Processor",myrank," computed Usccorr"
 242 C
 243 C 12/1/95 Multi-body terms
 244 C
 245       n_corr=0
 246       n_corr1=0
 247       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 248      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 249          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 250 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 251 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 252       else
 253          ecorr=0.0d0
 254          ecorr5=0.0d0
 255          ecorr6=0.0d0
 256          eturn6=0.0d0
 257       endif
 258       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 259          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 260 cd         write (iout,*) "multibody_hb ecorr",ecorr
 261       endif
 262 c      print *,"Processor",myrank," computed Ucorr"
 263 C
 264 C If performing constraint dynamics, call the constraint energy
 265 C  after the equilibration time
 266       if(usampl.and.totT.gt.eq_time) then
 267 c         call EconstrQ
 268          call Econstr_back
 269       else
 270          Uconst=0.0d0
 271          Uconst_back=0.0d0
 272       endif
 273 #ifdef TIMING
 274       time_enecalc=time_enecalc+MPI_Wtime()-time00
 275 #endif
 276 c      print *,"Processor",myrank," computed Uconstr"
 277 #ifdef TIMING
 278       time00=MPI_Wtime()
 279 #endif
 280 c
 281 C Sum the energies
 282 C
 283       energia(1)=evdw
 284 #ifdef SCP14
 285       energia(2)=evdw2-evdw2_14
 286       energia(18)=evdw2_14
 287 #else
 288       energia(2)=evdw2
 289       energia(18)=0.0d0
 290 #endif
 291 #ifdef SPLITELE
 292       energia(3)=ees
 293       energia(16)=evdw1
 294 #else
 295       energia(3)=ees+evdw1
 296       energia(16)=0.0d0
 297 #endif
 298       energia(4)=ecorr
 299       energia(5)=ecorr5
 300       energia(6)=ecorr6
 301       energia(7)=eel_loc
 302       energia(8)=eello_turn3
 303       energia(9)=eello_turn4
 304       energia(10)=eturn6
 305       energia(11)=ebe
 306       energia(12)=escloc
 307       energia(13)=etors
 308       energia(14)=etors_d
 309       energia(15)=ehpb
 310       energia(19)=edihcnstr
 311       energia(17)=estr
 312       energia(20)=Uconst+Uconst_back
 313       energia(21)=esccor
 314       energia(22)=evdw_p
 315       energia(23)=evdw_m
 316       energia(24)=edfadis
 317       energia(25)=edfator
 318       energia(26)=edfanei
 319       energia(27)=edfabet
 320 c      print *," Processor",myrank," calls SUM_ENERGY"
 321       call sum_energy(energia,.true.)
 322 c      print *," Processor",myrank," left SUM_ENERGY"
 323 #ifdef TIMING
 324       time_sumene=time_sumene+MPI_Wtime()-time00
 325 #endif
 326
 327 c      print*, 'etot:',energia(0)
 328
 329       return
 330       end
 331 c-------------------------------------------------------------------------------
 332       subroutine sum_energy(energia,reduce)
 333       implicit real*8 (a-h,o-z)
 334       include 'DIMENSIONS'
 335 #ifndef ISNAN
 336       external proc_proc
 337 #ifdef WINPGI
 338 cMS$ATTRIBUTES C ::  proc_proc
 339 #endif
 340 #endif
 341 #ifdef MPI
 342       include "mpif.h"
 343 #endif
 344       include 'COMMON.SETUP'
 345       include 'COMMON.IOUNITS'
 346       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 347       include 'COMMON.FFIELD'
 348       include 'COMMON.DERIV'
 349       include 'COMMON.INTERACT'
 350       include 'COMMON.SBRIDGE'
 351       include 'COMMON.CHAIN'
 352       include 'COMMON.VAR'
 353       include 'COMMON.CONTROL'
 354       include 'COMMON.TIME1'
 355       logical reduce
 356 #ifdef MPI
 357       if (nfgtasks.gt.1 .and. reduce) then
 358 #ifdef DEBUG
 359         write (iout,*) "energies before REDUCE"
 360         call enerprint(energia)
 361         call flush(iout)
 362 #endif
 363         do i=0,n_ene
 364           enebuff(i)=energia(i)
 365         enddo
 366         time00=MPI_Wtime()
 367         call MPI_Barrier(FG_COMM,IERR)
 368         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 369         time00=MPI_Wtime()
 370         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 371      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 372 #ifdef DEBUG
 373         write (iout,*) "energies after REDUCE"
 374         call enerprint(energia)
 375         call flush(iout)
 376 #endif
 377         time_Reduce=time_Reduce+MPI_Wtime()-time00
 378       endif
 379       if (fg_rank.eq.0) then
 380 #endif
 381 #ifdef TSCSC
 382       evdw=energia(22)+wsct*energia(23)
 383 #else
 384       evdw=energia(1)
 385 #endif
 386 #ifdef SCP14
 387       evdw2=energia(2)+energia(18)
 388       evdw2_14=energia(18)
 389 #else
 390       evdw2=energia(2)
 391 #endif
 392 #ifdef SPLITELE
 393       ees=energia(3)
 394       evdw1=energia(16)
 395 #else
 396       ees=energia(3)
 397       evdw1=0.0d0
 398 #endif
 399       ecorr=energia(4)
 400       ecorr5=energia(5)
 401       ecorr6=energia(6)
 402       eel_loc=energia(7)
 403       eello_turn3=energia(8)
 404       eello_turn4=energia(9)
 405       eturn6=energia(10)
 406       ebe=energia(11)
 407       escloc=energia(12)
 408       etors=energia(13)
 409       etors_d=energia(14)
 410       ehpb=energia(15)
 411       edihcnstr=energia(19)
 412       estr=energia(17)
 413       Uconst=energia(20)
 414       esccor=energia(21)
 415       edfadis=energia(24)
 416       edfator=energia(25)
 417       edfanei=energia(26)
 418       edfabet=energia(27)
 419 #ifdef SPLITELE
 420       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 421      & +wang*ebe+wtor*etors+wscloc*escloc
 422      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 423      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 424      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 425      & +wbond*estr+Uconst+wsccor*esccor
 426      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 427      & +wdfa_beta*edfabet
 428 #else
 429       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 430      & +wang*ebe+wtor*etors+wscloc*escloc
 431      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 432      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 433      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 434      & +wbond*estr+Uconst+wsccor*esccor
 435      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 436      & +wdfa_beta*edfabet
 437
 438 #endif
 439       energia(0)=etot
 440 c detecting NaNQ
 441 #ifdef ISNAN
 442 #ifdef AIX
 443       if (isnan(etot).ne.0) energia(0)=1.0d+99
 444 #else
 445       if (isnan(etot)) energia(0)=1.0d+99
 446 #endif
 447 #else
 448       i=0
 449 #ifdef WINPGI
 450       idumm=proc_proc(etot,i)
 451 #else
 452       call proc_proc(etot,i)
 453 #endif
 454       if(i.eq.1)energia(0)=1.0d+99
 455 #endif
 456 #ifdef MPI
 457       endif
 458 #endif
 459       return
 460       end
 461 c-------------------------------------------------------------------------------
 462       subroutine sum_gradient
 463       implicit real*8 (a-h,o-z)
 464       include 'DIMENSIONS'
 465 #ifndef ISNAN
 466       external proc_proc
 467 #ifdef WINPGI
 468 cMS$ATTRIBUTES C ::  proc_proc
 469 #endif
 470 #endif
 471 #ifdef MPI
 472       include 'mpif.h'
 473       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 474      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 475 #else
 476       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 477      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 478 #endif
 479       include 'COMMON.SETUP'
 480       include 'COMMON.IOUNITS'
 481       include 'COMMON.FFIELD'
 482       include 'COMMON.DERIV'
 483       include 'COMMON.INTERACT'
 484       include 'COMMON.SBRIDGE'
 485       include 'COMMON.CHAIN'
 486       include 'COMMON.VAR'
 487       include 'COMMON.CONTROL'
 488       include 'COMMON.TIME1'
 489       include 'COMMON.MAXGRAD'
 490 #ifdef TIMING
 491       time01=MPI_Wtime()
 492 #endif
 493 #ifdef DEBUG
 494       write (iout,*) "sum_gradient gvdwc, gvdwx"
 495       do i=1,nres
 496         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 497      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 498      &   (gvdwcT(j,i),j=1,3)
 499       enddo
 500       call flush(iout)
 501 #endif
 502 #ifdef MPI
 503 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 504         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 505      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 506 #endif
 507 C
 508 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 509 C            in virtual-bond-vector coordinates
 510 C
 511 #ifdef DEBUG
 512 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 513 c      do i=1,nres-1
 514 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 515 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 516 c      enddo
 517 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 518 c      do i=1,nres-1
 519 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 520 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 521 c      enddo
 522       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 523       do i=1,nres
 524         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 525      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 526      &   g_corr5_loc(i)
 527       enddo
 528       call flush(iout)
 529 #endif
 530 #ifdef SPLITELE
 531 #ifdef TSCSC
 532       do i=1,nct
 533         do j=1,3
 534           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 535      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 536      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 537      &                wel_loc*gel_loc_long(j,i)+
 538      &                wcorr*gradcorr_long(j,i)+
 539      &                wcorr5*gradcorr5_long(j,i)+
 540      &                wcorr6*gradcorr6_long(j,i)+
 541      &                wturn6*gcorr6_turn_long(j,i)+
 542      &                wstrain*ghpbc(j,i)+
 543      &                wdfa_dist*gdfad(j,i)+
 544      &                wdfa_tor*gdfat(j,i)+
 545      &                wdfa_nei*gdfan(j,i)+
 546      &                wdfa_beta*gdfab(j,i)
 547
 548         enddo
 549       enddo
 550 #else
 551       do i=1,nct
 552         do j=1,3
 553           gradbufc(j,i)=wsc*gvdwc(j,i)+
 554      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 555      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 556      &                wel_loc*gel_loc_long(j,i)+
 557      &                wcorr*gradcorr_long(j,i)+
 558      &                wcorr5*gradcorr5_long(j,i)+
 559      &                wcorr6*gradcorr6_long(j,i)+
 560      &                wturn6*gcorr6_turn_long(j,i)+
 561      &                wstrain*ghpbc(j,i)+
 562      &                wdfa_dist*gdfad(j,i)+
 563      &                wdfa_tor*gdfat(j,i)+
 564      &                wdfa_nei*gdfan(j,i)+
 565      &                wdfa_beta*gdfab(j,i)
 566
 567         enddo
 568       enddo
 569 #endif
 570 #else
 571       do i=1,nct
 572         do j=1,3
 573           gradbufc(j,i)=wsc*gvdwc(j,i)+
 574      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 575      &                welec*gelc_long(j,i)+
 576      &                wbond*gradb(j,i)+
 577      &                wel_loc*gel_loc_long(j,i)+
 578      &                wcorr*gradcorr_long(j,i)+
 579      &                wcorr5*gradcorr5_long(j,i)+
 580      &                wcorr6*gradcorr6_long(j,i)+
 581      &                wturn6*gcorr6_turn_long(j,i)+
 582      &                wstrain*ghpbc(j,i)+
 583      &                wdfa_dist*gdfad(j,i)+
 584      &                wdfa_tor*gdfat(j,i)+
 585      &                wdfa_nei*gdfan(j,i)+
 586      &                wdfa_beta*gdfab(j,i)
 587
 588
 589         enddo
 590       enddo
 591 #endif
 592 #ifdef MPI
 593       if (nfgtasks.gt.1) then
 594       time00=MPI_Wtime()
 595 #ifdef DEBUG
 596       write (iout,*) "gradbufc before allreduce"
 597       do i=1,nres
 598         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 599       enddo
 600       call flush(iout)
 601 #endif
 602       call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 603      &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 604       time_reduce=time_reduce+MPI_Wtime()-time00
 605 #ifdef DEBUG
 606       write (iout,*) "gradbufc_sum after allreduce"
 607       do i=1,nres
 608         write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 609       enddo
 610       call flush(iout)
 611 #endif
 612 #ifdef TIMING
 613       time_allreduce=time_allreduce+MPI_Wtime()-time00
 614 #endif
 615       do i=nnt,nres
 616         do k=1,3
 617           gradbufc(k,i)=0.0d0
 618         enddo
 619       enddo
 620       do i=igrad_start,igrad_end
 621         do j=jgrad_start(i),jgrad_end(i)
 622           do k=1,3
 623             gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 624           enddo
 625         enddo
 626       enddo
 627       else
 628 #endif
 629 #ifdef DEBUG
 630       write (iout,*) "gradbufc"
 631       do i=1,nres
 632         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 633       enddo
 634       call flush(iout)
 635 #endif
 636       do i=nnt,nres-1
 637         do k=1,3
 638           gradbufc(k,i)=0.0d0
 639         enddo
 640         do j=i+1,nres
 641           do k=1,3
 642             gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 643           enddo
 644         enddo
 645       enddo
 646 #ifdef MPI
 647       endif
 648 #endif
 649       do k=1,3
 650         gradbufc(k,nres)=0.0d0
 651       enddo
 652       do i=1,nct
 653         do j=1,3
 654 #ifdef SPLITELE
 655           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 656      &                wel_loc*gel_loc(j,i)+
 657      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 658      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 659      &                wel_loc*gel_loc_long(j,i)+
 660      &                wcorr*gradcorr_long(j,i)+
 661      &                wcorr5*gradcorr5_long(j,i)+
 662      &                wcorr6*gradcorr6_long(j,i)+
 663      &                wturn6*gcorr6_turn_long(j,i))+
 664      &                wbond*gradb(j,i)+
 665      &                wcorr*gradcorr(j,i)+
 666      &                wturn3*gcorr3_turn(j,i)+
 667      &                wturn4*gcorr4_turn(j,i)+
 668      &                wcorr5*gradcorr5(j,i)+
 669      &                wcorr6*gradcorr6(j,i)+
 670      &                wturn6*gcorr6_turn(j,i)+
 671      &                wsccor*gsccorc(j,i)
 672      &               +wscloc*gscloc(j,i)
 673 #else
 674           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 675      &                wel_loc*gel_loc(j,i)+
 676      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 677      &                welec*gelc_long(j,i)
 678      &                wel_loc*gel_loc_long(j,i)+
 679      &                wcorr*gcorr_long(j,i)+
 680      &                wcorr5*gradcorr5_long(j,i)+
 681      &                wcorr6*gradcorr6_long(j,i)+
 682      &                wturn6*gcorr6_turn_long(j,i))+
 683      &                wbond*gradb(j,i)+
 684      &                wcorr*gradcorr(j,i)+
 685      &                wturn3*gcorr3_turn(j,i)+
 686      &                wturn4*gcorr4_turn(j,i)+
 687      &                wcorr5*gradcorr5(j,i)+
 688      &                wcorr6*gradcorr6(j,i)+
 689      &                wturn6*gcorr6_turn(j,i)+
 690      &                wsccor*gsccorc(j,i)
 691      &               +wscloc*gscloc(j,i)
 692 #endif
 693 #ifdef TSCSC
 694           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 695      &                  wscp*gradx_scp(j,i)+
 696      &                  wbond*gradbx(j,i)+
 697      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 698      &                  wsccor*gsccorx(j,i)
 699      &                 +wscloc*gsclocx(j,i)
 700 #else
 701           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 702      &                  wbond*gradbx(j,i)+
 703      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 704      &                  wsccor*gsccorx(j,i)
 705      &                 +wscloc*gsclocx(j,i)
 706 #endif
 707         enddo
 708       enddo
 709 #ifdef DEBUG
 710       write (iout,*) "gloc before adding corr"
 711       do i=1,4*nres
 712         write (iout,*) i,gloc(i,icg)
 713       enddo
 714 #endif
 715       do i=1,nres-3
 716         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 717      &   +wcorr5*g_corr5_loc(i)
 718      &   +wcorr6*g_corr6_loc(i)
 719      &   +wturn4*gel_loc_turn4(i)
 720      &   +wturn3*gel_loc_turn3(i)
 721      &   +wturn6*gel_loc_turn6(i)
 722      &   +wel_loc*gel_loc_loc(i)
 723      &   +wsccor*gsccor_loc(i)
 724       enddo
 725 #ifdef DEBUG
 726       write (iout,*) "gloc after adding corr"
 727       do i=1,4*nres
 728         write (iout,*) i,gloc(i,icg)
 729       enddo
 730 #endif
 731 #ifdef MPI
 732       if (nfgtasks.gt.1) then
 733         do j=1,3
 734           do i=1,nres
 735             gradbufc(j,i)=gradc(j,i,icg)
 736             gradbufx(j,i)=gradx(j,i,icg)
 737           enddo
 738         enddo
 739         do i=1,4*nres
 740           glocbuf(i)=gloc(i,icg)
 741         enddo
 742         time00=MPI_Wtime()
 743         call MPI_Barrier(FG_COMM,IERR)
 744         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 745         time00=MPI_Wtime()
 746         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 747      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 748         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 749      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 750         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 751      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 752         time_reduce=time_reduce+MPI_Wtime()-time00
 753 #ifdef DEBUG
 754       write (iout,*) "gloc after reduce"
 755       do i=1,4*nres
 756         write (iout,*) i,gloc(i,icg)
 757       enddo
 758 #endif
 759       endif
 760 #endif
 761       if (gnorm_check) then
 762 c
 763 c Compute the maximum elements of the gradient
 764 c
 765       gvdwc_max=0.0d0
 766       gvdwc_scp_max=0.0d0
 767       gelc_max=0.0d0
 768       gvdwpp_max=0.0d0
 769       gradb_max=0.0d0
 770       ghpbc_max=0.0d0
 771       gradcorr_max=0.0d0
 772       gel_loc_max=0.0d0
 773       gcorr3_turn_max=0.0d0
 774       gcorr4_turn_max=0.0d0
 775       gradcorr5_max=0.0d0
 776       gradcorr6_max=0.0d0
 777       gcorr6_turn_max=0.0d0
 778       gsccorc_max=0.0d0
 779       gscloc_max=0.0d0
 780       gvdwx_max=0.0d0
 781       gradx_scp_max=0.0d0
 782       ghpbx_max=0.0d0
 783       gradxorr_max=0.0d0
 784       gsccorx_max=0.0d0
 785       gsclocx_max=0.0d0
 786       do i=1,nct
 787         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 788         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 789 #ifdef TSCSC
 790         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 791         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 792 #endif
 793         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 794         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 795      &   gvdwc_scp_max=gvdwc_scp_norm
 796         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 797         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 798         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 799         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 800         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 801         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 802         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 803         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 804         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 805         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 806         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 807         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 808         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 809      &    gcorr3_turn(1,i)))
 810         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 811      &    gcorr3_turn_max=gcorr3_turn_norm
 812         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 813      &    gcorr4_turn(1,i)))
 814         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 815      &    gcorr4_turn_max=gcorr4_turn_norm
 816         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 817         if (gradcorr5_norm.gt.gradcorr5_max)
 818      &    gradcorr5_max=gradcorr5_norm
 819         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 820         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 821         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 822      &    gcorr6_turn(1,i)))
 823         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 824      &    gcorr6_turn_max=gcorr6_turn_norm
 825         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 826         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 827         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 828         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 829         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 830         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 831 #ifdef TSCSC
 832         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 833         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 834 #endif
 835         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 836         if (gradx_scp_norm.gt.gradx_scp_max)
 837      &    gradx_scp_max=gradx_scp_norm
 838         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 839         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 840         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 841         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 842         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 843         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 844         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 845         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 846       enddo
 847       if (gradout) then
 848 #ifdef AIX
 849         open(istat,file=statname,position="append")
 850 #else
 851         open(istat,file=statname,access="append")
 852 #endif
 853         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 854      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 855      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 856      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 857      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 858      &     gsccorx_max,gsclocx_max
 859         close(istat)
 860         if (gvdwc_max.gt.1.0d4) then
 861           write (iout,*) "gvdwc gvdwx gradb gradbx"
 862           do i=nnt,nct
 863             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 864      &        gradb(j,i),gradbx(j,i),j=1,3)
 865           enddo
 866           call pdbout(0.0d0,'cipiszcze',iout)
 867           call flush(iout)
 868         endif
 869       endif
 870       endif
 871 #ifdef DEBUG
 872       write (iout,*) "gradc gradx gloc"
 873       do i=1,nres
 874         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 875      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 876       enddo
 877 #endif
 878 #ifdef TIMING
 879       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 880 #endif
 881       return
 882       end
 883 c-------------------------------------------------------------------------------
 884       subroutine rescale_weights(t_bath)
 885       implicit real*8 (a-h,o-z)
 886       include 'DIMENSIONS'
 887       include 'COMMON.IOUNITS'
 888       include 'COMMON.FFIELD'
 889       include 'COMMON.SBRIDGE'
 890       double precision kfac /2.4d0/
 891       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 892 c      facT=temp0/t_bath
 893 c      facT=2*temp0/(t_bath+temp0)
 894       if (rescale_mode.eq.0) then
 895         facT=1.0d0
 896         facT2=1.0d0
 897         facT3=1.0d0
 898         facT4=1.0d0
 899         facT5=1.0d0
 900       else if (rescale_mode.eq.1) then
 901         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 902         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 903         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 904         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 905         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 906       else if (rescale_mode.eq.2) then
 907         x=t_bath/temp0
 908         x2=x*x
 909         x3=x2*x
 910         x4=x3*x
 911         x5=x4*x
 912         facT=licznik/dlog(dexp(x)+dexp(-x))
 913         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 914         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 915         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 916         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 917       else
 918         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 919         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 920 #ifdef MPI
 921        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 922 #endif
 923        stop 555
 924       endif
 925       welec=weights(3)*fact
 926       wcorr=weights(4)*fact3
 927       wcorr5=weights(5)*fact4
 928       wcorr6=weights(6)*fact5
 929       wel_loc=weights(7)*fact2
 930       wturn3=weights(8)*fact2
 931       wturn4=weights(9)*fact3
 932       wturn6=weights(10)*fact5
 933       wtor=weights(13)*fact
 934       wtor_d=weights(14)*fact2
 935       wsccor=weights(21)*fact
 936 #ifdef TSCSC
 937 c      wsct=t_bath/temp0
 938       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 939 #endif
 940       return
 941       end
 942 C------------------------------------------------------------------------
 943       subroutine enerprint(energia)
 944       implicit real*8 (a-h,o-z)
 945       include 'DIMENSIONS'
 946       include 'COMMON.IOUNITS'
 947       include 'COMMON.FFIELD'
 948       include 'COMMON.SBRIDGE'
 949       include 'COMMON.MD_'
 950       double precision energia(0:n_ene)
 951       etot=energia(0)
 952 #ifdef TSCSC
 953       evdw=energia(22)+wsct*energia(23)
 954 #else
 955       evdw=energia(1)
 956 #endif
 957       evdw2=energia(2)
 958 #ifdef SCP14
 959       evdw2=energia(2)+energia(18)
 960 #else
 961       evdw2=energia(2)
 962 #endif
 963       ees=energia(3)
 964 #ifdef SPLITELE
 965       evdw1=energia(16)
 966 #endif
 967       ecorr=energia(4)
 968       ecorr5=energia(5)
 969       ecorr6=energia(6)
 970       eel_loc=energia(7)
 971       eello_turn3=energia(8)
 972       eello_turn4=energia(9)
 973       eello_turn6=energia(10)
 974       ebe=energia(11)
 975       escloc=energia(12)
 976       etors=energia(13)
 977       etors_d=energia(14)
 978       ehpb=energia(15)
 979       edihcnstr=energia(19)
 980       estr=energia(17)
 981       Uconst=energia(20)
 982       esccor=energia(21)
 983 C     Juyong
 984       edfadis = energia(24)
 985       edfator = energia(25)
 986       edfanei = energia(26)
 987       edfabet = energia(27)
 988 C
 989 #ifdef SPLITELE
 990       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 991      &  estr,wbond,ebe,wang,
 992      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 993      &  ecorr,wcorr,
 994      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 995      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 996      &  edihcnstr,ebr*nss,
 997      &  Uconst,edfadis,edfator,edfanei,edfabet,etot
 998    10 format (/'Virtual-chain energies:'//
 999      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1000      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1001      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1002      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1003      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1004      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1005      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1006      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1007      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1008      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1009      & ' (SS bridges & dist. cnstr.)'/
1010      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1011      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1012      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1013      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1014      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1015      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1016      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1017      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1018      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1019      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1020      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1021      & 'EDFAD= ',1pE16.6,' (DFA distance energy)'/
1022      & 'EDFAT= ',1pE16.6,' (DFA torsion energy)'/
1023      & 'EDFAN= ',1pE16.6,' (DFA NCa energy)'/
1024      & 'EDFAB= ',1pE16.6,' (DFA Beta energy)'/
1025      & 'ETOT=  ',1pE16.6,' (total)')
1026 #else
1027       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1028      &  estr,wbond,ebe,wang,
1029      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1030      &  ecorr,wcorr,
1031      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1032      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1033      &  ebr*nss,
1034      &  Uconst,edfadis,edfator,edfanei,edfabet,etot
1035    10 format (/'Virtual-chain energies:'//
1036      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1037      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1038      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1039      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1040      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1041      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1042      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1043      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1044      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1045      & ' (SS bridges & dist. cnstr.)'/
1046      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1047      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1048      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1049      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1050      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1051      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1052      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1053      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1054      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1055      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1056      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1057      & 'EDFAD= ',1pE16.6,' (DFA distance energy)'/
1058      & 'EDFAT= ',1pE16.6,' (DFA torsion energy)'/
1059      & 'EDFAN= ',1pE16.6,' (DFA NCa energy)'/
1060      & 'EDFAB= ',1pE16.6,' (DFA Beta energy)'/
1061      & 'ETOT=  ',1pE16.6,' (total)')
1062 #endif
1063       return
1064       end
1065 C-----------------------------------------------------------------------
1066       subroutine elj(evdw,evdw_p,evdw_m)
1067 C
1068 C This subroutine calculates the interaction energy of nonbonded side chains
1069 C assuming the LJ potential of interaction.
1070 C
1071       implicit real*8 (a-h,o-z)
1072       include 'DIMENSIONS'
1073       parameter (accur=1.0d-10)
1074       include 'COMMON.GEO'
1075       include 'COMMON.VAR'
1076       include 'COMMON.LOCAL'
1077       include 'COMMON.CHAIN'
1078       include 'COMMON.DERIV'
1079       include 'COMMON.INTERACT'
1080       include 'COMMON.TORSION'
1081       include 'COMMON.SBRIDGE'
1082       include 'COMMON.NAMES'
1083       include 'COMMON.IOUNITS'
1084       include 'COMMON.CONTACTS'
1085 #ifdef MOMENT
1086       include 'COMMON.CONTACTS.MOMENT'
1087 #endif
1088       dimension gg(3)
1089 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1090       evdw=0.0D0
1091       do i=iatsc_s,iatsc_e
1092         itypi=itype(i)
1093         itypi1=itype(i+1)
1094         xi=c(1,nres+i)
1095         yi=c(2,nres+i)
1096         zi=c(3,nres+i)
1097 C Change 12/1/95
1098         num_conti=0
1099 C
1100 C Calculate SC interaction energy.
1101 C
1102         do iint=1,nint_gr(i)
1103 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1104 cd   &                  'iend=',iend(i,iint)
1105           do j=istart(i,iint),iend(i,iint)
1106             itypj=itype(j)
1107             xj=c(1,nres+j)-xi
1108             yj=c(2,nres+j)-yi
1109             zj=c(3,nres+j)-zi
1110 C Change 12/1/95 to calculate four-body interactions
1111             rij=xj*xj+yj*yj+zj*zj
1112             rrij=1.0D0/rij
1113 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1114             eps0ij=eps(itypi,itypj)
1115             fac=rrij**expon2
1116             e1=fac*fac*aa(itypi,itypj)
1117             e2=fac*bb(itypi,itypj)
1118             evdwij=e1+e2
1119 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1120 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1121 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1122 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1123 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1124 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1125 #ifdef TSCSC
1126             if (bb(itypi,itypj).gt.0) then
1127                evdw_p=evdw_p+evdwij
1128             else
1129                evdw_m=evdw_m+evdwij
1130             endif
1131 #else
1132             evdw=evdw+evdwij
1133 #endif
1134 C
1135 C Calculate the components of the gradient in DC and X
1136 C
1137             fac=-rrij*(e1+evdwij)
1138             gg(1)=xj*fac
1139             gg(2)=yj*fac
1140             gg(3)=zj*fac
1141 #ifdef TSCSC
1142             if (bb(itypi,itypj).gt.0.0d0) then
1143               do k=1,3
1144                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1145                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1146                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1147                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1148               enddo
1149             else
1150               do k=1,3
1151                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1152                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1153                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1154                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1155               enddo
1156             endif
1157 #else
1158             do k=1,3
1159               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1160               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1161               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1162               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1163             enddo
1164 #endif
1165 cgrad            do k=i,j-1
1166 cgrad              do l=1,3
1167 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1168 cgrad              enddo
1169 cgrad            enddo
1170 C
1171 C 12/1/95, revised on 5/20/97
1172 C
1173 C Calculate the contact function. The ith column of the array JCONT will
1174 C contain the numbers of atoms that make contacts with the atom I (of numbers
1175 C greater than I). The arrays FACONT and GACONT will contain the values of
1176 C the contact function and its derivative.
1177 C
1178 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1179 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1180 C Uncomment next line, if the correlation interactions are contact function only
1181             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1182               rij=dsqrt(rij)
1183               sigij=sigma(itypi,itypj)
1184               r0ij=rs0(itypi,itypj)
1185 C
1186 C Check whether the SC's are not too far to make a contact.
1187 C
1188               rcut=1.5d0*r0ij
1189               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1190 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1191 C
1192               if (fcont.gt.0.0D0) then
1193 C If the SC-SC distance if close to sigma, apply spline.
1194 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1195 cAdam &             fcont1,fprimcont1)
1196 cAdam           fcont1=1.0d0-fcont1
1197 cAdam           if (fcont1.gt.0.0d0) then
1198 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1199 cAdam             fcont=fcont*fcont1
1200 cAdam           endif
1201 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1202 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1203 cga             do k=1,3
1204 cga               gg(k)=gg(k)*eps0ij
1205 cga             enddo
1206 cga             eps0ij=-evdwij*eps0ij
1207 C Uncomment for AL's type of SC correlation interactions.
1208 cadam           eps0ij=-evdwij
1209                 num_conti=num_conti+1
1210                 jcont(num_conti,i)=j
1211                 facont(num_conti,i)=fcont*eps0ij
1212                 fprimcont=eps0ij*fprimcont/rij
1213                 fcont=expon*fcont
1214 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1215 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1216 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1217 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1218                 gacont(1,num_conti,i)=-fprimcont*xj
1219                 gacont(2,num_conti,i)=-fprimcont*yj
1220                 gacont(3,num_conti,i)=-fprimcont*zj
1221 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1222 cd              write (iout,'(2i3,3f10.5)')
1223 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1224               endif
1225             endif
1226           enddo      ! j
1227         enddo        ! iint
1228 C Change 12/1/95
1229         num_cont(i)=num_conti
1230       enddo          ! i
1231       do i=1,nct
1232         do j=1,3
1233           gvdwc(j,i)=expon*gvdwc(j,i)
1234           gvdwx(j,i)=expon*gvdwx(j,i)
1235         enddo
1236       enddo
1237 C******************************************************************************
1238 C
1239 C                              N O T E !!!
1240 C
1241 C To save time, the factor of EXPON has been extracted from ALL components
1242 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1243 C use!
1244 C
1245 C******************************************************************************
1246       return
1247       end
1248 C-----------------------------------------------------------------------------
1249       subroutine eljk(evdw,evdw_p,evdw_m)
1250 C
1251 C This subroutine calculates the interaction energy of nonbonded side chains
1252 C assuming the LJK potential of interaction.
1253 C
1254       implicit real*8 (a-h,o-z)
1255       include 'DIMENSIONS'
1256       include 'COMMON.GEO'
1257       include 'COMMON.VAR'
1258       include 'COMMON.LOCAL'
1259       include 'COMMON.CHAIN'
1260       include 'COMMON.DERIV'
1261       include 'COMMON.INTERACT'
1262       include 'COMMON.IOUNITS'
1263       include 'COMMON.NAMES'
1264       dimension gg(3)
1265       logical scheck
1266 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1267       evdw=0.0D0
1268       do i=iatsc_s,iatsc_e
1269         itypi=itype(i)
1270         itypi1=itype(i+1)
1271         xi=c(1,nres+i)
1272         yi=c(2,nres+i)
1273         zi=c(3,nres+i)
1274 C
1275 C Calculate SC interaction energy.
1276 C
1277         do iint=1,nint_gr(i)
1278           do j=istart(i,iint),iend(i,iint)
1279             itypj=itype(j)
1280             xj=c(1,nres+j)-xi
1281             yj=c(2,nres+j)-yi
1282             zj=c(3,nres+j)-zi
1283             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1284             fac_augm=rrij**expon
1285             e_augm=augm(itypi,itypj)*fac_augm
1286             r_inv_ij=dsqrt(rrij)
1287             rij=1.0D0/r_inv_ij
1288             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1289             fac=r_shift_inv**expon
1290             e1=fac*fac*aa(itypi,itypj)
1291             e2=fac*bb(itypi,itypj)
1292             evdwij=e_augm+e1+e2
1293 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1294 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1295 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1296 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1297 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1298 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1299 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1300 #ifdef TSCSC
1301             if (bb(itypi,itypj).gt.0) then
1302                evdw_p=evdw_p+evdwij
1303             else
1304                evdw_m=evdw_m+evdwij
1305             endif
1306 #else
1307             evdw=evdw+evdwij
1308 #endif
1309 C
1310 C Calculate the components of the gradient in DC and X
1311 C
1312             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1313             gg(1)=xj*fac
1314             gg(2)=yj*fac
1315             gg(3)=zj*fac
1316 #ifdef TSCSC
1317             if (bb(itypi,itypj).gt.0.0d0) then
1318               do k=1,3
1319                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1320                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1321                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1322                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1323               enddo
1324             else
1325               do k=1,3
1326                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1327                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1328                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1329                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1330               enddo
1331             endif
1332 #else
1333             do k=1,3
1334               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1335               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1336               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1337               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1338             enddo
1339 #endif
1340 cgrad            do k=i,j-1
1341 cgrad              do l=1,3
1342 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1343 cgrad              enddo
1344 cgrad            enddo
1345           enddo      ! j
1346         enddo        ! iint
1347       enddo          ! i
1348       do i=1,nct
1349         do j=1,3
1350           gvdwc(j,i)=expon*gvdwc(j,i)
1351           gvdwx(j,i)=expon*gvdwx(j,i)
1352         enddo
1353       enddo
1354       return
1355       end
1356 C-----------------------------------------------------------------------------
1357       subroutine ebp(evdw,evdw_p,evdw_m)
1358 C
1359 C This subroutine calculates the interaction energy of nonbonded side chains
1360 C assuming the Berne-Pechukas potential of interaction.
1361 C
1362       implicit real*8 (a-h,o-z)
1363       include 'DIMENSIONS'
1364       include 'COMMON.GEO'
1365       include 'COMMON.VAR'
1366       include 'COMMON.LOCAL'
1367       include 'COMMON.CHAIN'
1368       include 'COMMON.DERIV'
1369       include 'COMMON.NAMES'
1370       include 'COMMON.INTERACT'
1371       include 'COMMON.IOUNITS'
1372       include 'COMMON.CALC'
1373       common /srutu/ icall
1374 c     double precision rrsave(maxdim)
1375       logical lprn
1376       evdw=0.0D0
1377 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1378       evdw=0.0D0
1379 c     if (icall.eq.0) then
1380 c       lprn=.true.
1381 c     else
1382         lprn=.false.
1383 c     endif
1384       ind=0
1385       do i=iatsc_s,iatsc_e
1386         itypi=itype(i)
1387         itypi1=itype(i+1)
1388         xi=c(1,nres+i)
1389         yi=c(2,nres+i)
1390         zi=c(3,nres+i)
1391         dxi=dc_norm(1,nres+i)
1392         dyi=dc_norm(2,nres+i)
1393         dzi=dc_norm(3,nres+i)
1394 c        dsci_inv=dsc_inv(itypi)
1395         dsci_inv=vbld_inv(i+nres)
1396 C
1397 C Calculate SC interaction energy.
1398 C
1399         do iint=1,nint_gr(i)
1400           do j=istart(i,iint),iend(i,iint)
1401             ind=ind+1
1402             itypj=itype(j)
1403 c            dscj_inv=dsc_inv(itypj)
1404             dscj_inv=vbld_inv(j+nres)
1405             chi1=chi(itypi,itypj)
1406             chi2=chi(itypj,itypi)
1407             chi12=chi1*chi2
1408             chip1=chip(itypi)
1409             chip2=chip(itypj)
1410             chip12=chip1*chip2
1411             alf1=alp(itypi)
1412             alf2=alp(itypj)
1413             alf12=0.5D0*(alf1+alf2)
1414 C For diagnostics only!!!
1415 c           chi1=0.0D0
1416 c           chi2=0.0D0
1417 c           chi12=0.0D0
1418 c           chip1=0.0D0
1419 c           chip2=0.0D0
1420 c           chip12=0.0D0
1421 c           alf1=0.0D0
1422 c           alf2=0.0D0
1423 c           alf12=0.0D0
1424             xj=c(1,nres+j)-xi
1425             yj=c(2,nres+j)-yi
1426             zj=c(3,nres+j)-zi
1427             dxj=dc_norm(1,nres+j)
1428             dyj=dc_norm(2,nres+j)
1429             dzj=dc_norm(3,nres+j)
1430             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1431 cd          if (icall.eq.0) then
1432 cd            rrsave(ind)=rrij
1433 cd          else
1434 cd            rrij=rrsave(ind)
1435 cd          endif
1436             rij=dsqrt(rrij)
1437 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1438             call sc_angular
1439 C Calculate whole angle-dependent part of epsilon and contributions
1440 C to its derivatives
1441             fac=(rrij*sigsq)**expon2
1442             e1=fac*fac*aa(itypi,itypj)
1443             e2=fac*bb(itypi,itypj)
1444             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1445             eps2der=evdwij*eps3rt
1446             eps3der=evdwij*eps2rt
1447             evdwij=evdwij*eps2rt*eps3rt
1448 #ifdef TSCSC
1449             if (bb(itypi,itypj).gt.0) then
1450                evdw_p=evdw_p+evdwij
1451             else
1452                evdw_m=evdw_m+evdwij
1453             endif
1454 #else
1455             evdw=evdw+evdwij
1456 #endif
1457             if (lprn) then
1458             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1459             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1460 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1461 cd     &        restyp(itypi),i,restyp(itypj),j,
1462 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1463 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1464 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1465 cd     &        evdwij
1466             endif
1467 C Calculate gradient components.
1468             e1=e1*eps1*eps2rt**2*eps3rt**2
1469             fac=-expon*(e1+evdwij)
1470             sigder=fac/sigsq
1471             fac=rrij*fac
1472 C Calculate radial part of the gradient
1473             gg(1)=xj*fac
1474             gg(2)=yj*fac
1475             gg(3)=zj*fac
1476 C Calculate the angular part of the gradient and sum add the contributions
1477 C to the appropriate components of the Cartesian gradient.
1478 #ifdef TSCSC
1479             if (bb(itypi,itypj).gt.0) then
1480                call sc_grad
1481             else
1482                call sc_grad_T
1483             endif
1484 #else
1485             call sc_grad
1486 #endif
1487           enddo      ! j
1488         enddo        ! iint
1489       enddo          ! i
1490 c     stop
1491       return
1492       end
1493 C-----------------------------------------------------------------------------
1494       subroutine egb(evdw,evdw_p,evdw_m)
1495 C
1496 C This subroutine calculates the interaction energy of nonbonded side chains
1497 C assuming the Gay-Berne potential of interaction.
1498 C
1499       implicit real*8 (a-h,o-z)
1500       include 'DIMENSIONS'
1501       include 'COMMON.GEO'
1502       include 'COMMON.VAR'
1503       include 'COMMON.LOCAL'
1504       include 'COMMON.CHAIN'
1505       include 'COMMON.DERIV'
1506       include 'COMMON.NAMES'
1507       include 'COMMON.INTERACT'
1508       include 'COMMON.IOUNITS'
1509       include 'COMMON.CALC'
1510       include 'COMMON.CONTROL'
1511       logical lprn
1512       evdw=0.0D0
1513 ccccc      energy_dec=.false.
1514 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1515       evdw=0.0D0
1516       evdw_p=0.0D0
1517       evdw_m=0.0D0
1518       lprn=.false.
1519 c     if (icall.eq.0) lprn=.false.
1520       ind=0
1521       do i=iatsc_s,iatsc_e
1522         itypi=itype(i)
1523         itypi1=itype(i+1)
1524         xi=c(1,nres+i)
1525         yi=c(2,nres+i)
1526         zi=c(3,nres+i)
1527         dxi=dc_norm(1,nres+i)
1528         dyi=dc_norm(2,nres+i)
1529         dzi=dc_norm(3,nres+i)
1530 c        dsci_inv=dsc_inv(itypi)
1531         dsci_inv=vbld_inv(i+nres)
1532 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1533 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1534 C
1535 C Calculate SC interaction energy.
1536 C
1537         do iint=1,nint_gr(i)
1538           do j=istart(i,iint),iend(i,iint)
1539             ind=ind+1
1540             itypj=itype(j)
1541 c            dscj_inv=dsc_inv(itypj)
1542             dscj_inv=vbld_inv(j+nres)
1543 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1544 c     &       1.0d0/vbld(j+nres)
1545 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1546             sig0ij=sigma(itypi,itypj)
1547             chi1=chi(itypi,itypj)
1548             chi2=chi(itypj,itypi)
1549             chi12=chi1*chi2
1550             chip1=chip(itypi)
1551             chip2=chip(itypj)
1552             chip12=chip1*chip2
1553             alf1=alp(itypi)
1554             alf2=alp(itypj)
1555             alf12=0.5D0*(alf1+alf2)
1556 C For diagnostics only!!!
1557 c           chi1=0.0D0
1558 c           chi2=0.0D0
1559 c           chi12=0.0D0
1560 c           chip1=0.0D0
1561 c           chip2=0.0D0
1562 c           chip12=0.0D0
1563 c           alf1=0.0D0
1564 c           alf2=0.0D0
1565 c           alf12=0.0D0
1566             xj=c(1,nres+j)-xi
1567             yj=c(2,nres+j)-yi
1568             zj=c(3,nres+j)-zi
1569             dxj=dc_norm(1,nres+j)
1570             dyj=dc_norm(2,nres+j)
1571             dzj=dc_norm(3,nres+j)
1572 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1573 c            write (iout,*) "j",j," dc_norm",
1574 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1575             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1576             rij=dsqrt(rrij)
1577 C Calculate angle-dependent terms of energy and contributions to their
1578 C derivatives.
1579             call sc_angular
1580             sigsq=1.0D0/sigsq
1581             sig=sig0ij*dsqrt(sigsq)
1582             rij_shift=1.0D0/rij-sig+sig0ij
1583 c for diagnostics; uncomment
1584 c            rij_shift=1.2*sig0ij
1585 C I hate to put IF's in the loops, but here don't have another choice!!!!
1586             if (rij_shift.le.0.0D0) then
1587               evdw=1.0D20
1588 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1589 cd     &        restyp(itypi),i,restyp(itypj),j,
1590 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1591               return
1592             endif
1593             sigder=-sig*sigsq
1594 c---------------------------------------------------------------
1595             rij_shift=1.0D0/rij_shift
1596             fac=rij_shift**expon
1597             e1=fac*fac*aa(itypi,itypj)
1598             e2=fac*bb(itypi,itypj)
1599             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1600             eps2der=evdwij*eps3rt
1601             eps3der=evdwij*eps2rt
1602 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1603 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1604             evdwij=evdwij*eps2rt*eps3rt
1605 #ifdef TSCSC
1606             if (bb(itypi,itypj).gt.0) then
1607                evdw_p=evdw_p+evdwij
1608             else
1609                evdw_m=evdw_m+evdwij
1610             endif
1611 #else
1612             evdw=evdw+evdwij
1613 #endif
1614             if (lprn) then
1615             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1616             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1617             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1618      &        restyp(itypi),i,restyp(itypj),j,
1619      &        epsi,sigm,chi1,chi2,chip1,chip2,
1620      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1621      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1622      &        evdwij
1623             endif
1624
1625             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1626      &                        'evdw',i,j,evdwij
1627
1628 C Calculate gradient components.
1629             e1=e1*eps1*eps2rt**2*eps3rt**2
1630             fac=-expon*(e1+evdwij)*rij_shift
1631             sigder=fac*sigder
1632             fac=rij*fac
1633 c            fac=0.0d0
1634 C Calculate the radial part of the gradient
1635             gg(1)=xj*fac
1636             gg(2)=yj*fac
1637             gg(3)=zj*fac
1638 C Calculate angular part of the gradient.
1639 #ifdef TSCSC
1640             if (bb(itypi,itypj).gt.0) then
1641                call sc_grad
1642             else
1643                call sc_grad_T
1644             endif
1645 #else
1646             call sc_grad
1647 #endif
1648           enddo      ! j
1649         enddo        ! iint
1650       enddo          ! i
1651 c      write (iout,*) "Number of loop steps in EGB:",ind
1652 cccc      energy_dec=.false.
1653       return
1654       end
1655 C-----------------------------------------------------------------------------
1656       subroutine egbv(evdw,evdw_p,evdw_m)
1657 C
1658 C This subroutine calculates the interaction energy of nonbonded side chains
1659 C assuming the Gay-Berne-Vorobjev potential of interaction.
1660 C
1661       implicit real*8 (a-h,o-z)
1662       include 'DIMENSIONS'
1663       include 'COMMON.GEO'
1664       include 'COMMON.VAR'
1665       include 'COMMON.LOCAL'
1666       include 'COMMON.CHAIN'
1667       include 'COMMON.DERIV'
1668       include 'COMMON.NAMES'
1669       include 'COMMON.INTERACT'
1670       include 'COMMON.IOUNITS'
1671       include 'COMMON.CALC'
1672       common /srutu/ icall
1673       logical lprn
1674       evdw=0.0D0
1675 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1676       evdw=0.0D0
1677       lprn=.false.
1678 c     if (icall.eq.0) lprn=.true.
1679       ind=0
1680       do i=iatsc_s,iatsc_e
1681         itypi=itype(i)
1682         itypi1=itype(i+1)
1683         xi=c(1,nres+i)
1684         yi=c(2,nres+i)
1685         zi=c(3,nres+i)
1686         dxi=dc_norm(1,nres+i)
1687         dyi=dc_norm(2,nres+i)
1688         dzi=dc_norm(3,nres+i)
1689 c        dsci_inv=dsc_inv(itypi)
1690         dsci_inv=vbld_inv(i+nres)
1691 C
1692 C Calculate SC interaction energy.
1693 C
1694         do iint=1,nint_gr(i)
1695           do j=istart(i,iint),iend(i,iint)
1696             ind=ind+1
1697             itypj=itype(j)
1698 c            dscj_inv=dsc_inv(itypj)
1699             dscj_inv=vbld_inv(j+nres)
1700             sig0ij=sigma(itypi,itypj)
1701             r0ij=r0(itypi,itypj)
1702             chi1=chi(itypi,itypj)
1703             chi2=chi(itypj,itypi)
1704             chi12=chi1*chi2
1705             chip1=chip(itypi)
1706             chip2=chip(itypj)
1707             chip12=chip1*chip2
1708             alf1=alp(itypi)
1709             alf2=alp(itypj)
1710             alf12=0.5D0*(alf1+alf2)
1711 C For diagnostics only!!!
1712 c           chi1=0.0D0
1713 c           chi2=0.0D0
1714 c           chi12=0.0D0
1715 c           chip1=0.0D0
1716 c           chip2=0.0D0
1717 c           chip12=0.0D0
1718 c           alf1=0.0D0
1719 c           alf2=0.0D0
1720 c           alf12=0.0D0
1721             xj=c(1,nres+j)-xi
1722             yj=c(2,nres+j)-yi
1723             zj=c(3,nres+j)-zi
1724             dxj=dc_norm(1,nres+j)
1725             dyj=dc_norm(2,nres+j)
1726             dzj=dc_norm(3,nres+j)
1727             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1728             rij=dsqrt(rrij)
1729 C Calculate angle-dependent terms of energy and contributions to their
1730 C derivatives.
1731             call sc_angular
1732             sigsq=1.0D0/sigsq
1733             sig=sig0ij*dsqrt(sigsq)
1734             rij_shift=1.0D0/rij-sig+r0ij
1735 C I hate to put IF's in the loops, but here don't have another choice!!!!
1736             if (rij_shift.le.0.0D0) then
1737               evdw=1.0D20
1738               return
1739             endif
1740             sigder=-sig*sigsq
1741 c---------------------------------------------------------------
1742             rij_shift=1.0D0/rij_shift
1743             fac=rij_shift**expon
1744             e1=fac*fac*aa(itypi,itypj)
1745             e2=fac*bb(itypi,itypj)
1746             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1747             eps2der=evdwij*eps3rt
1748             eps3der=evdwij*eps2rt
1749             fac_augm=rrij**expon
1750             e_augm=augm(itypi,itypj)*fac_augm
1751             evdwij=evdwij*eps2rt*eps3rt
1752 #ifdef TSCSC
1753             if (bb(itypi,itypj).gt.0) then
1754                evdw_p=evdw_p+evdwij+e_augm
1755             else
1756                evdw_m=evdw_m+evdwij+e_augm
1757             endif
1758 #else
1759             evdw=evdw+evdwij+e_augm
1760 #endif
1761             if (lprn) then
1762             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1763             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1764             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1765      &        restyp(itypi),i,restyp(itypj),j,
1766      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1767      &        chi1,chi2,chip1,chip2,
1768      &        eps1,eps2rt**2,eps3rt**2,
1769      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1770      &        evdwij+e_augm
1771             endif
1772 C Calculate gradient components.
1773             e1=e1*eps1*eps2rt**2*eps3rt**2
1774             fac=-expon*(e1+evdwij)*rij_shift
1775             sigder=fac*sigder
1776             fac=rij*fac-2*expon*rrij*e_augm
1777 C Calculate the radial part of the gradient
1778             gg(1)=xj*fac
1779             gg(2)=yj*fac
1780             gg(3)=zj*fac
1781 C Calculate angular part of the gradient.
1782 #ifdef TSCSC
1783             if (bb(itypi,itypj).gt.0) then
1784                call sc_grad
1785             else
1786                call sc_grad_T
1787             endif
1788 #else
1789             call sc_grad
1790 #endif
1791           enddo      ! j
1792         enddo        ! iint
1793       enddo          ! i
1794       end
1795 C-----------------------------------------------------------------------------
1796       subroutine sc_angular
1797 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1798 C om12. Called by ebp, egb, and egbv.
1799       implicit none
1800       include 'COMMON.CALC'
1801       include 'COMMON.IOUNITS'
1802       erij(1)=xj*rij
1803       erij(2)=yj*rij
1804       erij(3)=zj*rij
1805       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1806       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1807       om12=dxi*dxj+dyi*dyj+dzi*dzj
1808       chiom12=chi12*om12
1809 C Calculate eps1(om12) and its derivative in om12
1810       faceps1=1.0D0-om12*chiom12
1811       faceps1_inv=1.0D0/faceps1
1812       eps1=dsqrt(faceps1_inv)
1813 C Following variable is eps1*deps1/dom12
1814       eps1_om12=faceps1_inv*chiom12
1815 c diagnostics only
1816 c      faceps1_inv=om12
1817 c      eps1=om12
1818 c      eps1_om12=1.0d0
1819 c      write (iout,*) "om12",om12," eps1",eps1
1820 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1821 C and om12.
1822       om1om2=om1*om2
1823       chiom1=chi1*om1
1824       chiom2=chi2*om2
1825       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1826       sigsq=1.0D0-facsig*faceps1_inv
1827       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1828       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1829       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1830 c diagnostics only
1831 c      sigsq=1.0d0
1832 c      sigsq_om1=0.0d0
1833 c      sigsq_om2=0.0d0
1834 c      sigsq_om12=0.0d0
1835 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1836 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1837 c     &    " eps1",eps1
1838 C Calculate eps2 and its derivatives in om1, om2, and om12.
1839       chipom1=chip1*om1
1840       chipom2=chip2*om2
1841       chipom12=chip12*om12
1842       facp=1.0D0-om12*chipom12
1843       facp_inv=1.0D0/facp
1844       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1845 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1846 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1847 C Following variable is the square root of eps2
1848       eps2rt=1.0D0-facp1*facp_inv
1849 C Following three variables are the derivatives of the square root of eps
1850 C in om1, om2, and om12.
1851       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1852       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1853       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1854 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1855       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1856 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1857 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1858 c     &  " eps2rt_om12",eps2rt_om12
1859 C Calculate whole angle-dependent part of epsilon and contributions
1860 C to its derivatives
1861       return
1862       end
1863
1864 C----------------------------------------------------------------------------
1865       subroutine sc_grad_T
1866       implicit real*8 (a-h,o-z)
1867       include 'DIMENSIONS'
1868       include 'COMMON.CHAIN'
1869       include 'COMMON.DERIV'
1870       include 'COMMON.CALC'
1871       include 'COMMON.IOUNITS'
1872       double precision dcosom1(3),dcosom2(3)
1873       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1874       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1875       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1876      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1877 c diagnostics only
1878 c      eom1=0.0d0
1879 c      eom2=0.0d0
1880 c      eom12=evdwij*eps1_om12
1881 c end diagnostics
1882 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1883 c     &  " sigder",sigder
1884 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1885 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1886       do k=1,3
1887         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1888         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1889       enddo
1890       do k=1,3
1891         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1892       enddo
1893 c      write (iout,*) "gg",(gg(k),k=1,3)
1894       do k=1,3
1895         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1896      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1897      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1898         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1899      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1900      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1901 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1902 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1903 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1904 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1905       enddo
1906 C
1907 C Calculate the components of the gradient in DC and X
1908 C
1909 cgrad      do k=i,j-1
1910 cgrad        do l=1,3
1911 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1912 cgrad        enddo
1913 cgrad      enddo
1914       do l=1,3
1915         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1916         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1917       enddo
1918       return
1919       end
1920
1921 C----------------------------------------------------------------------------
1922       subroutine sc_grad
1923       implicit real*8 (a-h,o-z)
1924       include 'DIMENSIONS'
1925       include 'COMMON.CHAIN'
1926       include 'COMMON.DERIV'
1927       include 'COMMON.CALC'
1928       include 'COMMON.IOUNITS'
1929       double precision dcosom1(3),dcosom2(3)
1930       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1931       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1932       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1933      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1934 c diagnostics only
1935 c      eom1=0.0d0
1936 c      eom2=0.0d0
1937 c      eom12=evdwij*eps1_om12
1938 c end diagnostics
1939 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1940 c     &  " sigder",sigder
1941 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1942 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1943       do k=1,3
1944         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1945         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1946       enddo
1947       do k=1,3
1948         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1949       enddo
1950 c      write (iout,*) "gg",(gg(k),k=1,3)
1951       do k=1,3
1952         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1953      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1954      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1955         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1956      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1957      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1958 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1959 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1960 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1961 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1962       enddo
1963 C
1964 C Calculate the components of the gradient in DC and X
1965 C
1966 cgrad      do k=i,j-1
1967 cgrad        do l=1,3
1968 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1969 cgrad        enddo
1970 cgrad      enddo
1971       do l=1,3
1972         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1973         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1974       enddo
1975       return
1976       end
1977 C-----------------------------------------------------------------------
1978       subroutine e_softsphere(evdw)
1979 C
1980 C This subroutine calculates the interaction energy of nonbonded side chains
1981 C assuming the LJ potential of interaction.
1982 C
1983       implicit real*8 (a-h,o-z)
1984       include 'DIMENSIONS'
1985       parameter (accur=1.0d-10)
1986       include 'COMMON.GEO'
1987       include 'COMMON.VAR'
1988       include 'COMMON.LOCAL'
1989       include 'COMMON.CHAIN'
1990       include 'COMMON.DERIV'
1991       include 'COMMON.INTERACT'
1992       include 'COMMON.TORSION'
1993       include 'COMMON.SBRIDGE'
1994       include 'COMMON.NAMES'
1995       include 'COMMON.IOUNITS'
1996       include 'COMMON.CONTACTS'
1997 #ifdef MOMENT
1998       include 'COMMON.CONTACTS.MOMENT'
1999 #endif
2000       dimension gg(3)
2001 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2002       evdw=0.0D0
2003       do i=iatsc_s,iatsc_e
2004         itypi=itype(i)
2005         itypi1=itype(i+1)
2006         xi=c(1,nres+i)
2007         yi=c(2,nres+i)
2008         zi=c(3,nres+i)
2009 C
2010 C Calculate SC interaction energy.
2011 C
2012         do iint=1,nint_gr(i)
2013 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2014 cd   &                  'iend=',iend(i,iint)
2015           do j=istart(i,iint),iend(i,iint)
2016             itypj=itype(j)
2017             xj=c(1,nres+j)-xi
2018             yj=c(2,nres+j)-yi
2019             zj=c(3,nres+j)-zi
2020             rij=xj*xj+yj*yj+zj*zj
2021 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2022             r0ij=r0(itypi,itypj)
2023             r0ijsq=r0ij*r0ij
2024 c            print *,i,j,r0ij,dsqrt(rij)
2025             if (rij.lt.r0ijsq) then
2026               evdwij=0.25d0*(rij-r0ijsq)**2
2027               fac=rij-r0ijsq
2028             else
2029               evdwij=0.0d0
2030               fac=0.0d0
2031             endif
2032             evdw=evdw+evdwij
2033 C
2034 C Calculate the components of the gradient in DC and X
2035 C
2036             gg(1)=xj*fac
2037             gg(2)=yj*fac
2038             gg(3)=zj*fac
2039             do k=1,3
2040               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2041               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2042               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2043               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2044             enddo
2045 cgrad            do k=i,j-1
2046 cgrad              do l=1,3
2047 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2048 cgrad              enddo
2049 cgrad            enddo
2050           enddo ! j
2051         enddo ! iint
2052       enddo ! i
2053       return
2054       end
2055 C--------------------------------------------------------------------------
2056       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2057      &              eello_turn4)
2058 C
2059 C Soft-sphere potential of p-p interaction
2060 C
2061       implicit real*8 (a-h,o-z)
2062       include 'DIMENSIONS'
2063       include 'COMMON.CONTROL'
2064       include 'COMMON.IOUNITS'
2065       include 'COMMON.GEO'
2066       include 'COMMON.VAR'
2067       include 'COMMON.LOCAL'
2068       include 'COMMON.CHAIN'
2069       include 'COMMON.DERIV'
2070       include 'COMMON.INTERACT'
2071       include 'COMMON.CONTACTS'
2072 #ifdef MOMENT
2073       include 'COMMON.CONTACTS.MOMENT'
2074 #endif
2075       include 'COMMON.TORSION'
2076       include 'COMMON.VECTORS'
2077       include 'COMMON.FFIELD'
2078       dimension ggg(3)
2079 cd      write(iout,*) 'In EELEC_soft_sphere'
2080       ees=0.0D0
2081       evdw1=0.0D0
2082       eel_loc=0.0d0
2083       eello_turn3=0.0d0
2084       eello_turn4=0.0d0
2085       ind=0
2086       do i=iatel_s,iatel_e
2087         dxi=dc(1,i)
2088         dyi=dc(2,i)
2089         dzi=dc(3,i)
2090         xmedi=c(1,i)+0.5d0*dxi
2091         ymedi=c(2,i)+0.5d0*dyi
2092         zmedi=c(3,i)+0.5d0*dzi
2093         num_conti=0
2094 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2095         do j=ielstart(i),ielend(i)
2096           ind=ind+1
2097           iteli=itel(i)
2098           itelj=itel(j)
2099           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2100           r0ij=rpp(iteli,itelj)
2101           r0ijsq=r0ij*r0ij
2102           dxj=dc(1,j)
2103           dyj=dc(2,j)
2104           dzj=dc(3,j)
2105           xj=c(1,j)+0.5D0*dxj-xmedi
2106           yj=c(2,j)+0.5D0*dyj-ymedi
2107           zj=c(3,j)+0.5D0*dzj-zmedi
2108           rij=xj*xj+yj*yj+zj*zj
2109           if (rij.lt.r0ijsq) then
2110             evdw1ij=0.25d0*(rij-r0ijsq)**2
2111             fac=rij-r0ijsq
2112           else
2113             evdw1ij=0.0d0
2114             fac=0.0d0
2115           endif
2116           evdw1=evdw1+evdw1ij
2117 C
2118 C Calculate contributions to the Cartesian gradient.
2119 C
2120           ggg(1)=fac*xj
2121           ggg(2)=fac*yj
2122           ggg(3)=fac*zj
2123           do k=1,3
2124             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2125             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2126           enddo
2127 *
2128 * Loop over residues i+1 thru j-1.
2129 *
2130 cgrad          do k=i+1,j-1
2131 cgrad            do l=1,3
2132 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2133 cgrad            enddo
2134 cgrad          enddo
2135         enddo ! j
2136       enddo   ! i
2137 cgrad      do i=nnt,nct-1
2138 cgrad        do k=1,3
2139 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2140 cgrad        enddo
2141 cgrad        do j=i+1,nct-1
2142 cgrad          do k=1,3
2143 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2144 cgrad          enddo
2145 cgrad        enddo
2146 cgrad      enddo
2147       return
2148       end
2149 c------------------------------------------------------------------------------
2150       subroutine vec_and_deriv
2151       implicit real*8 (a-h,o-z)
2152       include 'DIMENSIONS'
2153 #ifdef MPI
2154       include 'mpif.h'
2155 #endif
2156       include 'COMMON.IOUNITS'
2157       include 'COMMON.GEO'
2158       include 'COMMON.VAR'
2159       include 'COMMON.LOCAL'
2160       include 'COMMON.CHAIN'
2161       include 'COMMON.VECTORS'
2162       include 'COMMON.SETUP'
2163       include 'COMMON.TIME1'
2164       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2165 C Compute the local reference systems. For reference system (i), the
2166 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2167 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2168 #ifdef PARVEC
2169       do i=ivec_start,ivec_end
2170 #else
2171       do i=1,nres-1
2172 #endif
2173           if (i.eq.nres-1) then
2174 C Case of the last full residue
2175 C Compute the Z-axis
2176             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2177             costh=dcos(pi-theta(nres))
2178             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2179             do k=1,3
2180               uz(k,i)=fac*uz(k,i)
2181             enddo
2182 C Compute the derivatives of uz
2183             uzder(1,1,1)= 0.0d0
2184             uzder(2,1,1)=-dc_norm(3,i-1)
2185             uzder(3,1,1)= dc_norm(2,i-1)
2186             uzder(1,2,1)= dc_norm(3,i-1)
2187             uzder(2,2,1)= 0.0d0
2188             uzder(3,2,1)=-dc_norm(1,i-1)
2189             uzder(1,3,1)=-dc_norm(2,i-1)
2190             uzder(2,3,1)= dc_norm(1,i-1)
2191             uzder(3,3,1)= 0.0d0
2192             uzder(1,1,2)= 0.0d0
2193             uzder(2,1,2)= dc_norm(3,i)
2194             uzder(3,1,2)=-dc_norm(2,i)
2195             uzder(1,2,2)=-dc_norm(3,i)
2196             uzder(2,2,2)= 0.0d0
2197             uzder(3,2,2)= dc_norm(1,i)
2198             uzder(1,3,2)= dc_norm(2,i)
2199             uzder(2,3,2)=-dc_norm(1,i)
2200             uzder(3,3,2)= 0.0d0
2201 C Compute the Y-axis
2202             facy=fac
2203             do k=1,3
2204               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2205             enddo
2206 C Compute the derivatives of uy
2207             do j=1,3
2208               do k=1,3
2209                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2210      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2211                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2212               enddo
2213               uyder(j,j,1)=uyder(j,j,1)-costh
2214               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2215             enddo
2216             do j=1,2
2217               do k=1,3
2218                 do l=1,3
2219                   uygrad(l,k,j,i)=uyder(l,k,j)
2220                   uzgrad(l,k,j,i)=uzder(l,k,j)
2221                 enddo
2222               enddo
2223             enddo
2224             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2225             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2226             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2227             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2228           else
2229 C Other residues
2230 C Compute the Z-axis
2231             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2232             costh=dcos(pi-theta(i+2))
2233             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2234             do k=1,3
2235               uz(k,i)=fac*uz(k,i)
2236             enddo
2237 C Compute the derivatives of uz
2238             uzder(1,1,1)= 0.0d0
2239             uzder(2,1,1)=-dc_norm(3,i+1)
2240             uzder(3,1,1)= dc_norm(2,i+1)
2241             uzder(1,2,1)= dc_norm(3,i+1)
2242             uzder(2,2,1)= 0.0d0
2243             uzder(3,2,1)=-dc_norm(1,i+1)
2244             uzder(1,3,1)=-dc_norm(2,i+1)
2245             uzder(2,3,1)= dc_norm(1,i+1)
2246             uzder(3,3,1)= 0.0d0
2247             uzder(1,1,2)= 0.0d0
2248             uzder(2,1,2)= dc_norm(3,i)
2249             uzder(3,1,2)=-dc_norm(2,i)
2250             uzder(1,2,2)=-dc_norm(3,i)
2251             uzder(2,2,2)= 0.0d0
2252             uzder(3,2,2)= dc_norm(1,i)
2253             uzder(1,3,2)= dc_norm(2,i)
2254             uzder(2,3,2)=-dc_norm(1,i)
2255             uzder(3,3,2)= 0.0d0
2256 C Compute the Y-axis
2257             facy=fac
2258             do k=1,3
2259               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2260             enddo
2261 C Compute the derivatives of uy
2262             do j=1,3
2263               do k=1,3
2264                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2265      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2266                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2267               enddo
2268               uyder(j,j,1)=uyder(j,j,1)-costh
2269               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2270             enddo
2271             do j=1,2
2272               do k=1,3
2273                 do l=1,3
2274                   uygrad(l,k,j,i)=uyder(l,k,j)
2275                   uzgrad(l,k,j,i)=uzder(l,k,j)
2276                 enddo
2277               enddo
2278             enddo
2279             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2280             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2281             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2282             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2283           endif
2284       enddo
2285       do i=1,nres-1
2286         vbld_inv_temp(1)=vbld_inv(i+1)
2287         if (i.lt.nres-1) then
2288           vbld_inv_temp(2)=vbld_inv(i+2)
2289           else
2290           vbld_inv_temp(2)=vbld_inv(i)
2291           endif
2292         do j=1,2
2293           do k=1,3
2294             do l=1,3
2295               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2296               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2297             enddo
2298           enddo
2299         enddo
2300       enddo
2301 #if defined(PARVEC) && defined(MPI)
2302       if (nfgtasks1.gt.1) then
2303         time00=MPI_Wtime()
2304 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2305 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2306 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2307         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2308      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2309      &   FG_COMM1,IERR)
2310         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2311      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2312      &   FG_COMM1,IERR)
2313         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2314      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2315      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2316         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2317      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2318      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2319         time_gather=time_gather+MPI_Wtime()-time00
2320       endif
2321 c      if (fg_rank.eq.0) then
2322 c        write (iout,*) "Arrays UY and UZ"
2323 c        do i=1,nres-1
2324 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2325 c     &     (uz(k,i),k=1,3)
2326 c        enddo
2327 c      endif
2328 #endif
2329       return
2330       end
2331 C-----------------------------------------------------------------------------
2332       subroutine check_vecgrad
2333       implicit real*8 (a-h,o-z)
2334       include 'DIMENSIONS'
2335       include 'COMMON.IOUNITS'
2336       include 'COMMON.GEO'
2337       include 'COMMON.VAR'
2338       include 'COMMON.LOCAL'
2339       include 'COMMON.CHAIN'
2340       include 'COMMON.VECTORS'
2341       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2342       dimension uyt(3,maxres),uzt(3,maxres)
2343       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2344       double precision delta /1.0d-7/
2345       call vec_and_deriv
2346 cd      do i=1,nres
2347 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2348 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2349 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2350 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2351 cd     &     (dc_norm(if90,i),if90=1,3)
2352 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2353 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2354 cd          write(iout,'(a)')
2355 cd      enddo
2356       do i=1,nres
2357         do j=1,2
2358           do k=1,3
2359             do l=1,3
2360               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2361               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2362             enddo
2363           enddo
2364         enddo
2365       enddo
2366       call vec_and_deriv
2367       do i=1,nres
2368         do j=1,3
2369           uyt(j,i)=uy(j,i)
2370           uzt(j,i)=uz(j,i)
2371         enddo
2372       enddo
2373       do i=1,nres
2374 cd        write (iout,*) 'i=',i
2375         do k=1,3
2376           erij(k)=dc_norm(k,i)
2377         enddo
2378         do j=1,3
2379           do k=1,3
2380             dc_norm(k,i)=erij(k)
2381           enddo
2382           dc_norm(j,i)=dc_norm(j,i)+delta
2383 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2384 c          do k=1,3
2385 c            dc_norm(k,i)=dc_norm(k,i)/fac
2386 c          enddo
2387 c          write (iout,*) (dc_norm(k,i),k=1,3)
2388 c          write (iout,*) (erij(k),k=1,3)
2389           call vec_and_deriv
2390           do k=1,3
2391             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2392             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2393             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2394             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2395           enddo
2396 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2397 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2398 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2399         enddo
2400         do k=1,3
2401           dc_norm(k,i)=erij(k)
2402         enddo
2403 cd        do k=1,3
2404 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2405 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2406 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2407 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2408 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2409 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2410 cd          write (iout,'(a)')
2411 cd        enddo
2412       enddo
2413       return
2414       end
2415 C--------------------------------------------------------------------------
2416       subroutine set_matrices
2417       implicit real*8 (a-h,o-z)
2418       include 'DIMENSIONS'
2419 #ifdef MPI
2420       include "mpif.h"
2421       include "COMMON.SETUP"
2422       integer IERR
2423       integer status(MPI_STATUS_SIZE)
2424 #endif
2425       include 'COMMON.IOUNITS'
2426       include 'COMMON.GEO'
2427       include 'COMMON.VAR'
2428       include 'COMMON.LOCAL'
2429       include 'COMMON.CHAIN'
2430       include 'COMMON.DERIV'
2431       include 'COMMON.INTERACT'
2432       include 'COMMON.CONTACTS'
2433 #ifdef MOMENT
2434       include 'COMMON.CONTACTS.MOMENT'
2435 #endif
2436       include 'COMMON.TORSION'
2437       include 'COMMON.VECTORS'
2438       include 'COMMON.FFIELD'
2439       double precision auxvec(2),auxmat(2,2)
2440 C
2441 C Compute the virtual-bond-torsional-angle dependent quantities needed
2442 C to calculate the el-loc multibody terms of various order.
2443 C
2444 #ifdef PARMAT
2445       do i=ivec_start+2,ivec_end+2
2446 #else
2447       do i=3,nres+1
2448 #endif
2449         if (i .lt. nres+1) then
2450           sin1=dsin(phi(i))
2451           cos1=dcos(phi(i))
2452           sintab(i-2)=sin1
2453           costab(i-2)=cos1
2454           obrot(1,i-2)=cos1
2455           obrot(2,i-2)=sin1
2456           sin2=dsin(2*phi(i))
2457           cos2=dcos(2*phi(i))
2458           sintab2(i-2)=sin2
2459           costab2(i-2)=cos2
2460           obrot2(1,i-2)=cos2
2461           obrot2(2,i-2)=sin2
2462           Ug(1,1,i-2)=-cos1
2463           Ug(1,2,i-2)=-sin1
2464           Ug(2,1,i-2)=-sin1
2465           Ug(2,2,i-2)= cos1
2466           Ug2(1,1,i-2)=-cos2
2467           Ug2(1,2,i-2)=-sin2
2468           Ug2(2,1,i-2)=-sin2
2469           Ug2(2,2,i-2)= cos2
2470         else
2471           costab(i-2)=1.0d0
2472           sintab(i-2)=0.0d0
2473           obrot(1,i-2)=1.0d0
2474           obrot(2,i-2)=0.0d0
2475           obrot2(1,i-2)=0.0d0
2476           obrot2(2,i-2)=0.0d0
2477           Ug(1,1,i-2)=1.0d0
2478           Ug(1,2,i-2)=0.0d0
2479           Ug(2,1,i-2)=0.0d0
2480           Ug(2,2,i-2)=1.0d0
2481           Ug2(1,1,i-2)=0.0d0
2482           Ug2(1,2,i-2)=0.0d0
2483           Ug2(2,1,i-2)=0.0d0
2484           Ug2(2,2,i-2)=0.0d0
2485         endif
2486         if (i .gt. 3 .and. i .lt. nres+1) then
2487           obrot_der(1,i-2)=-sin1
2488           obrot_der(2,i-2)= cos1
2489           Ugder(1,1,i-2)= sin1
2490           Ugder(1,2,i-2)=-cos1
2491           Ugder(2,1,i-2)=-cos1
2492           Ugder(2,2,i-2)=-sin1
2493           dwacos2=cos2+cos2
2494           dwasin2=sin2+sin2
2495           obrot2_der(1,i-2)=-dwasin2
2496           obrot2_der(2,i-2)= dwacos2
2497           Ug2der(1,1,i-2)= dwasin2
2498           Ug2der(1,2,i-2)=-dwacos2
2499           Ug2der(2,1,i-2)=-dwacos2
2500           Ug2der(2,2,i-2)=-dwasin2
2501         else
2502           obrot_der(1,i-2)=0.0d0
2503           obrot_der(2,i-2)=0.0d0
2504           Ugder(1,1,i-2)=0.0d0
2505           Ugder(1,2,i-2)=0.0d0
2506           Ugder(2,1,i-2)=0.0d0
2507           Ugder(2,2,i-2)=0.0d0
2508           obrot2_der(1,i-2)=0.0d0
2509           obrot2_der(2,i-2)=0.0d0
2510           Ug2der(1,1,i-2)=0.0d0
2511           Ug2der(1,2,i-2)=0.0d0
2512           Ug2der(2,1,i-2)=0.0d0
2513           Ug2der(2,2,i-2)=0.0d0
2514         endif
2515 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2516         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2517           iti = itortyp(itype(i-2))
2518         else
2519           iti=ntortyp+1
2520         endif
2521 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2522         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2523           iti1 = itortyp(itype(i-1))
2524         else
2525           iti1=ntortyp+1
2526         endif
2527 cd        write (iout,*) '*******i',i,' iti1',iti
2528 cd        write (iout,*) 'b1',b1(:,iti)
2529 cd        write (iout,*) 'b2',b2(:,iti)
2530 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2531 c        if (i .gt. iatel_s+2) then
2532         if (i .gt. nnt+2) then
2533           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2534           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2535           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2536      &    then
2537           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2538           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2539           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2540           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2541           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2542           endif
2543         else
2544           do k=1,2
2545             Ub2(k,i-2)=0.0d0
2546             Ctobr(k,i-2)=0.0d0
2547             Dtobr2(k,i-2)=0.0d0
2548             do l=1,2
2549               EUg(l,k,i-2)=0.0d0
2550               CUg(l,k,i-2)=0.0d0
2551               DUg(l,k,i-2)=0.0d0
2552               DtUg2(l,k,i-2)=0.0d0
2553             enddo
2554           enddo
2555         endif
2556         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2557         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2558         do k=1,2
2559           muder(k,i-2)=Ub2der(k,i-2)
2560         enddo
2561 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2562         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2563           iti1 = itortyp(itype(i-1))
2564         else
2565           iti1=ntortyp+1
2566         endif
2567         do k=1,2
2568           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2569         enddo
2570 cd        write (iout,*) 'mu ',mu(:,i-2)
2571 cd        write (iout,*) 'mu1',mu1(:,i-2)
2572 cd        write (iout,*) 'mu2',mu2(:,i-2)
2573         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2574      &  then
2575         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2576         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2577         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2578         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2579         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2580 C Vectors and matrices dependent on a single virtual-bond dihedral.
2581         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2582         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2583         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2584         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2585         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2586         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2587         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2588         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2589         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2590         endif
2591       enddo
2592 C Matrices dependent on two consecutive virtual-bond dihedrals.
2593 C The order of matrices is from left to right.
2594       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2595      &then
2596 c      do i=max0(ivec_start,2),ivec_end
2597       do i=2,nres-1
2598         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2599         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2600         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2601         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2602         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2603         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2604         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2605         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2606       enddo
2607       endif
2608 #if defined(MPI) && defined(PARMAT)
2609 #ifdef DEBUG
2610 c      if (fg_rank.eq.0) then
2611         write (iout,*) "Arrays UG and UGDER before GATHER"
2612         do i=1,nres-1
2613           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2614      &     ((ug(l,k,i),l=1,2),k=1,2),
2615      &     ((ugder(l,k,i),l=1,2),k=1,2)
2616         enddo
2617         write (iout,*) "Arrays UG2 and UG2DER"
2618         do i=1,nres-1
2619           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2620      &     ((ug2(l,k,i),l=1,2),k=1,2),
2621      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2622         enddo
2623         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2624         do i=1,nres-1
2625           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2626      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2627      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2628         enddo
2629         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2630         do i=1,nres-1
2631           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2632      &     costab(i),sintab(i),costab2(i),sintab2(i)
2633         enddo
2634         write (iout,*) "Array MUDER"
2635         do i=1,nres-1
2636           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2637         enddo
2638 c      endif
2639 #endif
2640       if (nfgtasks.gt.1) then
2641         time00=MPI_Wtime()
2642 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2643 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2644 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2645 #ifdef MATGATHER
2646         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2647      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2648      &   FG_COMM1,IERR)
2649         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2650      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2651      &   FG_COMM1,IERR)
2652         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2653      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2654      &   FG_COMM1,IERR)
2655         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2656      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2657      &   FG_COMM1,IERR)
2658         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2659      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2660      &   FG_COMM1,IERR)
2661         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2662      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2663      &   FG_COMM1,IERR)
2664         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2665      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2666      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2667         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2668      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2669      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2670         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2671      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2672      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2673         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2674      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2675      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2676         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2677      &  then
2678         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2679      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2680      &   FG_COMM1,IERR)
2681         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2682      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2683      &   FG_COMM1,IERR)
2684         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2685      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2686      &   FG_COMM1,IERR)
2687        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2688      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2689      &   FG_COMM1,IERR)
2690         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2691      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2692      &   FG_COMM1,IERR)
2693         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2694      &   ivec_count(fg_rank1),
2695      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2696      &   FG_COMM1,IERR)
2697         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2698      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2699      &   FG_COMM1,IERR)
2700         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2701      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2702      &   FG_COMM1,IERR)
2703         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2704      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2705      &   FG_COMM1,IERR)
2706         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2707      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2708      &   FG_COMM1,IERR)
2709         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2710      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2711      &   FG_COMM1,IERR)
2712         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2713      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2714      &   FG_COMM1,IERR)
2715         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2716      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2717      &   FG_COMM1,IERR)
2718         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2719      &   ivec_count(fg_rank1),
2720      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2721      &   FG_COMM1,IERR)
2722         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2723      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2724      &   FG_COMM1,IERR)
2725        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2726      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2727      &   FG_COMM1,IERR)
2728         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2729      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2730      &   FG_COMM1,IERR)
2731        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2732      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2733      &   FG_COMM1,IERR)
2734         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2735      &   ivec_count(fg_rank1),
2736      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2737      &   FG_COMM1,IERR)
2738         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2739      &   ivec_count(fg_rank1),
2740      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2741      &   FG_COMM1,IERR)
2742         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2743      &   ivec_count(fg_rank1),
2744      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2745      &   MPI_MAT2,FG_COMM1,IERR)
2746         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2747      &   ivec_count(fg_rank1),
2748      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2749      &   MPI_MAT2,FG_COMM1,IERR)
2750         endif
2751 #else
2752 c Passes matrix info through the ring
2753       isend=fg_rank1
2754       irecv=fg_rank1-1
2755       if (irecv.lt.0) irecv=nfgtasks1-1
2756       iprev=irecv
2757       inext=fg_rank1+1
2758       if (inext.ge.nfgtasks1) inext=0
2759       do i=1,nfgtasks1-1
2760 c        write (iout,*) "isend",isend," irecv",irecv
2761 c        call flush(iout)
2762         lensend=lentyp(isend)
2763         lenrecv=lentyp(irecv)
2764 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2765 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2766 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2767 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2768 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2769 c        write (iout,*) "Gather ROTAT1"
2770 c        call flush(iout)
2771 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2772 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2773 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2774 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2775 c        write (iout,*) "Gather ROTAT2"
2776 c        call flush(iout)
2777         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2778      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2779      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2780      &   iprev,4400+irecv,FG_COMM,status,IERR)
2781 c        write (iout,*) "Gather ROTAT_OLD"
2782 c        call flush(iout)
2783         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2784      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2785      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2786      &   iprev,5500+irecv,FG_COMM,status,IERR)
2787 c        write (iout,*) "Gather PRECOMP11"
2788 c        call flush(iout)
2789         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2790      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2791      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2792      &   iprev,6600+irecv,FG_COMM,status,IERR)
2793 c        write (iout,*) "Gather PRECOMP12"
2794 c        call flush(iout)
2795         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2796      &  then
2797         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2798      &   MPI_ROTAT2(lensend),inext,7700+isend,
2799      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2800      &   iprev,7700+irecv,FG_COMM,status,IERR)
2801 c        write (iout,*) "Gather PRECOMP21"
2802 c        call flush(iout)
2803         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2804      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2805      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2806      &   iprev,8800+irecv,FG_COMM,status,IERR)
2807 c        write (iout,*) "Gather PRECOMP22"
2808 c        call flush(iout)
2809         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2810      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2811      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2812      &   MPI_PRECOMP23(lenrecv),
2813      &   iprev,9900+irecv,FG_COMM,status,IERR)
2814 c        write (iout,*) "Gather PRECOMP23"
2815 c        call flush(iout)
2816         endif
2817         isend=irecv
2818         irecv=irecv-1
2819         if (irecv.lt.0) irecv=nfgtasks1-1
2820       enddo
2821 #endif
2822         time_gather=time_gather+MPI_Wtime()-time00
2823       endif
2824 #ifdef DEBUG
2825 c      if (fg_rank.eq.0) then
2826         write (iout,*) "Arrays UG and UGDER"
2827         do i=1,nres-1
2828           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2829      &     ((ug(l,k,i),l=1,2),k=1,2),
2830      &     ((ugder(l,k,i),l=1,2),k=1,2)
2831         enddo
2832         write (iout,*) "Arrays UG2 and UG2DER"
2833         do i=1,nres-1
2834           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2835      &     ((ug2(l,k,i),l=1,2),k=1,2),
2836      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2837         enddo
2838         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2839         do i=1,nres-1
2840           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2841      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2842      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2843         enddo
2844         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2845         do i=1,nres-1
2846           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2847      &     costab(i),sintab(i),costab2(i),sintab2(i)
2848         enddo
2849         write (iout,*) "Array MUDER"
2850         do i=1,nres-1
2851           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2852         enddo
2853 c      endif
2854 #endif
2855 #endif
2856 cd      do i=1,nres
2857 cd        iti = itortyp(itype(i))
2858 cd        write (iout,*) i
2859 cd        do j=1,2
2860 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2861 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2862 cd        enddo
2863 cd      enddo
2864       return
2865       end
2866 C--------------------------------------------------------------------------
2867       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2868 C
2869 C This subroutine calculates the average interaction energy and its gradient
2870 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2871 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2872 C The potential depends both on the distance of peptide-group centers and on
2873 C the orientation of the CA-CA virtual bonds.
2874 C
2875       implicit real*8 (a-h,o-z)
2876 #ifdef MPI
2877       include 'mpif.h'
2878 #endif
2879       include 'DIMENSIONS'
2880       include 'COMMON.CONTROL'
2881       include 'COMMON.SETUP'
2882       include 'COMMON.IOUNITS'
2883       include 'COMMON.GEO'
2884       include 'COMMON.VAR'
2885       include 'COMMON.LOCAL'
2886       include 'COMMON.CHAIN'
2887       include 'COMMON.DERIV'
2888       include 'COMMON.INTERACT'
2889       include 'COMMON.CONTACTS'
2890 #ifdef MOMENT
2891       include 'COMMON.CONTACTS.MOMENT'
2892 #endif
2893       include 'COMMON.TORSION'
2894       include 'COMMON.VECTORS'
2895       include 'COMMON.FFIELD'
2896       include 'COMMON.TIME1'
2897       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2898      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2899       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2900      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2901       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2902      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2903      &    num_conti,j1,j2
2904 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2905 #ifdef MOMENT
2906       double precision scal_el /1.0d0/
2907 #else
2908       double precision scal_el /0.5d0/
2909 #endif
2910 C 12/13/98
2911 C 13-go grudnia roku pamietnego...
2912       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2913      &                   0.0d0,1.0d0,0.0d0,
2914      &                   0.0d0,0.0d0,1.0d0/
2915 cd      write(iout,*) 'In EELEC'
2916 cd      do i=1,nloctyp
2917 cd        write(iout,*) 'Type',i
2918 cd        write(iout,*) 'B1',B1(:,i)
2919 cd        write(iout,*) 'B2',B2(:,i)
2920 cd        write(iout,*) 'CC',CC(:,:,i)
2921 cd        write(iout,*) 'DD',DD(:,:,i)
2922 cd        write(iout,*) 'EE',EE(:,:,i)
2923 cd      enddo
2924 cd      call check_vecgrad
2925 cd      stop
2926       if (icheckgrad.eq.1) then
2927         do i=1,nres-1
2928           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2929           do k=1,3
2930             dc_norm(k,i)=dc(k,i)*fac
2931           enddo
2932 c          write (iout,*) 'i',i,' fac',fac
2933         enddo
2934       endif
2935       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2936      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2937      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2938 c        call vec_and_deriv
2939 #ifdef TIMING
2940         time01=MPI_Wtime()
2941 #endif
2942         call set_matrices
2943 #ifdef TIMING
2944         time_mat=time_mat+MPI_Wtime()-time01
2945 #endif
2946       endif
2947 cd      do i=1,nres-1
2948 cd        write (iout,*) 'i=',i
2949 cd        do k=1,3
2950 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2951 cd        enddo
2952 cd        do k=1,3
2953 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2954 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2955 cd        enddo
2956 cd      enddo
2957       t_eelecij=0.0d0
2958       ees=0.0D0
2959       evdw1=0.0D0
2960       eel_loc=0.0d0
2961       eello_turn3=0.0d0
2962       eello_turn4=0.0d0
2963       ind=0
2964       do i=1,nres
2965         num_cont_hb(i)=0
2966       enddo
2967 cd      print '(a)','Enter EELEC'
2968 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2969       do i=1,nres
2970         gel_loc_loc(i)=0.0d0
2971         gcorr_loc(i)=0.0d0
2972       enddo
2973 c
2974 c
2975 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2976 C
2977 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2978 C
2979       do i=iturn3_start,iturn3_end
2980         dxi=dc(1,i)
2981         dyi=dc(2,i)
2982         dzi=dc(3,i)
2983         dx_normi=dc_norm(1,i)
2984         dy_normi=dc_norm(2,i)
2985         dz_normi=dc_norm(3,i)
2986         xmedi=c(1,i)+0.5d0*dxi
2987         ymedi=c(2,i)+0.5d0*dyi
2988         zmedi=c(3,i)+0.5d0*dzi
2989         num_conti=0
2990         call eelecij(i,i+2,ees,evdw1,eel_loc)
2991         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2992         num_cont_hb(i)=num_conti
2993       enddo
2994       do i=iturn4_start,iturn4_end
2995         dxi=dc(1,i)
2996         dyi=dc(2,i)
2997         dzi=dc(3,i)
2998         dx_normi=dc_norm(1,i)
2999         dy_normi=dc_norm(2,i)
3000         dz_normi=dc_norm(3,i)
3001         xmedi=c(1,i)+0.5d0*dxi
3002         ymedi=c(2,i)+0.5d0*dyi
3003         zmedi=c(3,i)+0.5d0*dzi
3004         num_conti=num_cont_hb(i)
3005         call eelecij(i,i+3,ees,evdw1,eel_loc)
3006         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3007         num_cont_hb(i)=num_conti
3008       enddo   ! i
3009 c
3010 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3011 c
3012       do i=iatel_s,iatel_e
3013         dxi=dc(1,i)
3014         dyi=dc(2,i)
3015         dzi=dc(3,i)
3016         dx_normi=dc_norm(1,i)
3017         dy_normi=dc_norm(2,i)
3018         dz_normi=dc_norm(3,i)
3019         xmedi=c(1,i)+0.5d0*dxi
3020         ymedi=c(2,i)+0.5d0*dyi
3021         zmedi=c(3,i)+0.5d0*dzi
3022 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3023         num_conti=num_cont_hb(i)
3024         do j=ielstart(i),ielend(i)
3025           call eelecij(i,j,ees,evdw1,eel_loc)
3026         enddo ! j
3027         num_cont_hb(i)=num_conti
3028       enddo   ! i
3029 c      write (iout,*) "Number of loop steps in EELEC:",ind
3030 cd      do i=1,nres
3031 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3032 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3033 cd      enddo
3034 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3035 ccc      eel_loc=eel_loc+eello_turn3
3036 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3037       return
3038       end
3039 C-------------------------------------------------------------------------------
3040       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3041       implicit real*8 (a-h,o-z)
3042       include 'DIMENSIONS'
3043 #ifdef MPI
3044       include "mpif.h"
3045 #endif
3046       include 'COMMON.CONTROL'
3047       include 'COMMON.IOUNITS'
3048       include 'COMMON.GEO'
3049       include 'COMMON.VAR'
3050       include 'COMMON.LOCAL'
3051       include 'COMMON.CHAIN'
3052       include 'COMMON.DERIV'
3053       include 'COMMON.INTERACT'
3054       include 'COMMON.CONTACTS'
3055 #ifdef MOMENT
3056       include 'COMMON.CONTACTS.MOMENT'
3057 #endif
3058       include 'COMMON.TORSION'
3059       include 'COMMON.VECTORS'
3060       include 'COMMON.FFIELD'
3061       include 'COMMON.TIME1'
3062       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3063      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3064       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3065      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3066       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3067      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3068      &    num_conti,j1,j2
3069 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3070 #ifdef MOMENT
3071       double precision scal_el /1.0d0/
3072 #else
3073       double precision scal_el /0.5d0/
3074 #endif
3075 C 12/13/98
3076 C 13-go grudnia roku pamietnego...
3077       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3078      &                   0.0d0,1.0d0,0.0d0,
3079      &                   0.0d0,0.0d0,1.0d0/
3080 c          time00=MPI_Wtime()
3081 cd      write (iout,*) "eelecij",i,j
3082 c          ind=ind+1
3083           iteli=itel(i)
3084           itelj=itel(j)
3085           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3086           aaa=app(iteli,itelj)
3087           bbb=bpp(iteli,itelj)
3088           ael6i=ael6(iteli,itelj)
3089           ael3i=ael3(iteli,itelj)
3090           dxj=dc(1,j)
3091           dyj=dc(2,j)
3092           dzj=dc(3,j)
3093           dx_normj=dc_norm(1,j)
3094           dy_normj=dc_norm(2,j)
3095           dz_normj=dc_norm(3,j)
3096           xj=c(1,j)+0.5D0*dxj-xmedi
3097           yj=c(2,j)+0.5D0*dyj-ymedi
3098           zj=c(3,j)+0.5D0*dzj-zmedi
3099           rij=xj*xj+yj*yj+zj*zj
3100           rrmij=1.0D0/rij
3101           rij=dsqrt(rij)
3102           rmij=1.0D0/rij
3103           r3ij=rrmij*rmij
3104           r6ij=r3ij*r3ij
3105           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3106           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3107           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3108           fac=cosa-3.0D0*cosb*cosg
3109           ev1=aaa*r6ij*r6ij
3110 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3111           if (j.eq.i+2) ev1=scal_el*ev1
3112           ev2=bbb*r6ij
3113           fac3=ael6i*r6ij
3114           fac4=ael3i*r3ij
3115           evdwij=ev1+ev2
3116           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3117           el2=fac4*fac
3118           eesij=el1+el2
3119 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3120           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3121           ees=ees+eesij
3122           evdw1=evdw1+evdwij
3123 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3124 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3125 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3126 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3127
3128           if (energy_dec) then
3129               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3130               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3131           endif
3132
3133 C
3134 C Calculate contributions to the Cartesian gradient.
3135 C
3136 #ifdef SPLITELE
3137           facvdw=-6*rrmij*(ev1+evdwij)
3138           facel=-3*rrmij*(el1+eesij)
3139           fac1=fac
3140           erij(1)=xj*rmij
3141           erij(2)=yj*rmij
3142           erij(3)=zj*rmij
3143 *
3144 * Radial derivatives. First process both termini of the fragment (i,j)
3145 *
3146           ggg(1)=facel*xj
3147           ggg(2)=facel*yj
3148           ggg(3)=facel*zj
3149 c          do k=1,3
3150 c            ghalf=0.5D0*ggg(k)
3151 c            gelc(k,i)=gelc(k,i)+ghalf
3152 c            gelc(k,j)=gelc(k,j)+ghalf
3153 c          enddo
3154 c 9/28/08 AL Gradient compotents will be summed only at the end
3155           do k=1,3
3156             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3157             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3158           enddo
3159 *
3160 * Loop over residues i+1 thru j-1.
3161 *
3162 cgrad          do k=i+1,j-1
3163 cgrad            do l=1,3
3164 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3165 cgrad            enddo
3166 cgrad          enddo
3167           ggg(1)=facvdw*xj
3168           ggg(2)=facvdw*yj
3169           ggg(3)=facvdw*zj
3170 c          do k=1,3
3171 c            ghalf=0.5D0*ggg(k)
3172 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3173 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3174 c          enddo
3175 c 9/28/08 AL Gradient compotents will be summed only at the end
3176           do k=1,3
3177             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3178             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3179           enddo
3180 *
3181 * Loop over residues i+1 thru j-1.
3182 *
3183 cgrad          do k=i+1,j-1
3184 cgrad            do l=1,3
3185 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3186 cgrad            enddo
3187 cgrad          enddo
3188 #else
3189           facvdw=ev1+evdwij
3190           facel=el1+eesij
3191           fac1=fac
3192           fac=-3*rrmij*(facvdw+facvdw+facel)
3193           erij(1)=xj*rmij
3194           erij(2)=yj*rmij
3195           erij(3)=zj*rmij
3196 *
3197 * Radial derivatives. First process both termini of the fragment (i,j)
3198 *
3199           ggg(1)=fac*xj
3200           ggg(2)=fac*yj
3201           ggg(3)=fac*zj
3202 c          do k=1,3
3203 c            ghalf=0.5D0*ggg(k)
3204 c            gelc(k,i)=gelc(k,i)+ghalf
3205 c            gelc(k,j)=gelc(k,j)+ghalf
3206 c          enddo
3207 c 9/28/08 AL Gradient compotents will be summed only at the end
3208           do k=1,3
3209             gelc_long(k,j)=gelc(k,j)+ggg(k)
3210             gelc_long(k,i)=gelc(k,i)-ggg(k)
3211           enddo
3212 *
3213 * Loop over residues i+1 thru j-1.
3214 *
3215 cgrad          do k=i+1,j-1
3216 cgrad            do l=1,3
3217 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3218 cgrad            enddo
3219 cgrad          enddo
3220 c 9/28/08 AL Gradient compotents will be summed only at the end
3221           ggg(1)=facvdw*xj
3222           ggg(2)=facvdw*yj
3223           ggg(3)=facvdw*zj
3224           do k=1,3
3225             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3226             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3227           enddo
3228 #endif
3229 *
3230 * Angular part
3231 *
3232           ecosa=2.0D0*fac3*fac1+fac4
3233           fac4=-3.0D0*fac4
3234           fac3=-6.0D0*fac3
3235           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3236           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3237           do k=1,3
3238             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3239             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3240           enddo
3241 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3242 cd   &          (dcosg(k),k=1,3)
3243           do k=1,3
3244             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3245           enddo
3246 c          do k=1,3
3247 c            ghalf=0.5D0*ggg(k)
3248 c            gelc(k,i)=gelc(k,i)+ghalf
3249 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3250 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3251 c            gelc(k,j)=gelc(k,j)+ghalf
3252 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3253 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3254 c          enddo
3255 cgrad          do k=i+1,j-1
3256 cgrad            do l=1,3
3257 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3258 cgrad            enddo
3259 cgrad          enddo
3260           do k=1,3
3261             gelc(k,i)=gelc(k,i)
3262      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3263      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3264             gelc(k,j)=gelc(k,j)
3265      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3266      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3267             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3268             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3269           enddo
3270           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3271      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3272      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3273 C
3274 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3275 C   energy of a peptide unit is assumed in the form of a second-order
3276 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3277 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3278 C   are computed for EVERY pair of non-contiguous peptide groups.
3279 C
3280           if (j.lt.nres-1) then
3281             j1=j+1
3282             j2=j-1
3283           else
3284             j1=j-1
3285             j2=j-2
3286           endif
3287           kkk=0
3288           do k=1,2
3289             do l=1,2
3290               kkk=kkk+1
3291               muij(kkk)=mu(k,i)*mu(l,j)
3292             enddo
3293           enddo
3294 cd         write (iout,*) 'EELEC: i',i,' j',j
3295 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3296 cd          write(iout,*) 'muij',muij
3297           ury=scalar(uy(1,i),erij)
3298           urz=scalar(uz(1,i),erij)
3299           vry=scalar(uy(1,j),erij)
3300           vrz=scalar(uz(1,j),erij)
3301           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3302           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3303           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3304           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3305           fac=dsqrt(-ael6i)*r3ij
3306           a22=a22*fac
3307           a23=a23*fac
3308           a32=a32*fac
3309           a33=a33*fac
3310 cd          write (iout,'(4i5,4f10.5)')
3311 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3312 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3313 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3314 cd     &      uy(:,j),uz(:,j)
3315 cd          write (iout,'(4f10.5)')
3316 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3317 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3318 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3319 cd           write (iout,'(9f10.5/)')
3320 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3321 C Derivatives of the elements of A in virtual-bond vectors
3322           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3323           do k=1,3
3324             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3325             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3326             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3327             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3328             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3329             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3330             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3331             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3332             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3333             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3334             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3335             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3336           enddo
3337 C Compute radial contributions to the gradient
3338           facr=-3.0d0*rrmij
3339           a22der=a22*facr
3340           a23der=a23*facr
3341           a32der=a32*facr
3342           a33der=a33*facr
3343           agg(1,1)=a22der*xj
3344           agg(2,1)=a22der*yj
3345           agg(3,1)=a22der*zj
3346           agg(1,2)=a23der*xj
3347           agg(2,2)=a23der*yj
3348           agg(3,2)=a23der*zj
3349           agg(1,3)=a32der*xj
3350           agg(2,3)=a32der*yj
3351           agg(3,3)=a32der*zj
3352           agg(1,4)=a33der*xj
3353           agg(2,4)=a33der*yj
3354           agg(3,4)=a33der*zj
3355 C Add the contributions coming from er
3356           fac3=-3.0d0*fac
3357           do k=1,3
3358             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3359             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3360             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3361             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3362           enddo
3363           do k=1,3
3364 C Derivatives in DC(i)
3365 cgrad            ghalf1=0.5d0*agg(k,1)
3366 cgrad            ghalf2=0.5d0*agg(k,2)
3367 cgrad            ghalf3=0.5d0*agg(k,3)
3368 cgrad            ghalf4=0.5d0*agg(k,4)
3369             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3370      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3371             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3372      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3373             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3374      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3375             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3376      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3377 C Derivatives in DC(i+1)
3378             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3379      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3380             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3381      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3382             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3383      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3384             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3385      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3386 C Derivatives in DC(j)
3387             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3388      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3389             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3390      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3391             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3392      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3393             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3394      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3395 C Derivatives in DC(j+1) or DC(nres-1)
3396             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3397      &      -3.0d0*vryg(k,3)*ury)
3398             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3399      &      -3.0d0*vrzg(k,3)*ury)
3400             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3401      &      -3.0d0*vryg(k,3)*urz)
3402             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3403      &      -3.0d0*vrzg(k,3)*urz)
3404 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3405 cgrad              do l=1,4
3406 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3407 cgrad              enddo
3408 cgrad            endif
3409           enddo
3410           acipa(1,1)=a22
3411           acipa(1,2)=a23
3412           acipa(2,1)=a32
3413           acipa(2,2)=a33
3414           a22=-a22
3415           a23=-a23
3416           do l=1,2
3417             do k=1,3
3418               agg(k,l)=-agg(k,l)
3419               aggi(k,l)=-aggi(k,l)
3420               aggi1(k,l)=-aggi1(k,l)
3421               aggj(k,l)=-aggj(k,l)
3422               aggj1(k,l)=-aggj1(k,l)
3423             enddo
3424           enddo
3425           if (j.lt.nres-1) then
3426             a22=-a22
3427             a32=-a32
3428             do l=1,3,2
3429               do k=1,3
3430                 agg(k,l)=-agg(k,l)
3431                 aggi(k,l)=-aggi(k,l)
3432                 aggi1(k,l)=-aggi1(k,l)
3433                 aggj(k,l)=-aggj(k,l)
3434                 aggj1(k,l)=-aggj1(k,l)
3435               enddo
3436             enddo
3437           else
3438             a22=-a22
3439             a23=-a23
3440             a32=-a32
3441             a33=-a33
3442             do l=1,4
3443               do k=1,3
3444                 agg(k,l)=-agg(k,l)
3445                 aggi(k,l)=-aggi(k,l)
3446                 aggi1(k,l)=-aggi1(k,l)
3447                 aggj(k,l)=-aggj(k,l)
3448                 aggj1(k,l)=-aggj1(k,l)
3449               enddo
3450             enddo
3451           endif
3452           ENDIF ! WCORR
3453           IF (wel_loc.gt.0.0d0) THEN
3454 C Contribution to the local-electrostatic energy coming from the i-j pair
3455           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3456      &     +a33*muij(4)
3457 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3458
3459           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3460      &            'eelloc',i,j,eel_loc_ij
3461
3462           eel_loc=eel_loc+eel_loc_ij
3463 C Partial derivatives in virtual-bond dihedral angles gamma
3464           if (i.gt.1)
3465      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3466      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3467      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3468           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3469      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3470      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3471 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3472           do l=1,3
3473             ggg(l)=agg(l,1)*muij(1)+
3474      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3475             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3476             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3477 cgrad            ghalf=0.5d0*ggg(l)
3478 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3479 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3480           enddo
3481 cgrad          do k=i+1,j2
3482 cgrad            do l=1,3
3483 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3484 cgrad            enddo
3485 cgrad          enddo
3486 C Remaining derivatives of eello
3487           do l=1,3
3488             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3489      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3490             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3491      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3492             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3493      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3494             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3495      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3496           enddo
3497           ENDIF
3498 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3499 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3500           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3501      &       .and. num_conti.le.maxconts) then
3502 c            write (iout,*) i,j," entered corr"
3503 C
3504 C Calculate the contact function. The ith column of the array JCONT will
3505 C contain the numbers of atoms that make contacts with the atom I (of numbers
3506 C greater than I). The arrays FACONT and GACONT will contain the values of
3507 C the contact function and its derivative.
3508 c           r0ij=1.02D0*rpp(iteli,itelj)
3509 c           r0ij=1.11D0*rpp(iteli,itelj)
3510             r0ij=2.20D0*rpp(iteli,itelj)
3511 c           r0ij=1.55D0*rpp(iteli,itelj)
3512             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3513             if (fcont.gt.0.0D0) then
3514               num_conti=num_conti+1
3515               if (num_conti.gt.maxconts) then
3516                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3517      &                         ' will skip next contacts for this conf.'
3518               else
3519                 jcont_hb(num_conti,i)=j
3520 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3521 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3522                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3523      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3524 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3525 C  terms.
3526                 d_cont(num_conti,i)=rij
3527 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3528 C     --- Electrostatic-interaction matrix ---
3529                 a_chuj(1,1,num_conti,i)=a22
3530                 a_chuj(1,2,num_conti,i)=a23
3531                 a_chuj(2,1,num_conti,i)=a32
3532                 a_chuj(2,2,num_conti,i)=a33
3533 C     --- Gradient of rij
3534                 do kkk=1,3
3535                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3536                 enddo
3537                 kkll=0
3538                 do k=1,2
3539                   do l=1,2
3540                     kkll=kkll+1
3541                     do m=1,3
3542                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3543                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3544                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3545                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3546                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3547                     enddo
3548                   enddo
3549                 enddo
3550                 ENDIF
3551                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3552 C Calculate contact energies
3553                 cosa4=4.0D0*cosa
3554                 wij=cosa-3.0D0*cosb*cosg
3555                 cosbg1=cosb+cosg
3556                 cosbg2=cosb-cosg
3557 c               fac3=dsqrt(-ael6i)/r0ij**3
3558                 fac3=dsqrt(-ael6i)*r3ij
3559 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3560                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3561                 if (ees0tmp.gt.0) then
3562                   ees0pij=dsqrt(ees0tmp)
3563                 else
3564                   ees0pij=0
3565                 endif
3566 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3567                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3568                 if (ees0tmp.gt.0) then
3569                   ees0mij=dsqrt(ees0tmp)
3570                 else
3571                   ees0mij=0
3572                 endif
3573 c               ees0mij=0.0D0
3574                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3575                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3576 C Diagnostics. Comment out or remove after debugging!
3577 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3578 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3579 c               ees0m(num_conti,i)=0.0D0
3580 C End diagnostics.
3581 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3582 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3583 C Angular derivatives of the contact function
3584                 ees0pij1=fac3/ees0pij
3585                 ees0mij1=fac3/ees0mij
3586                 fac3p=-3.0D0*fac3*rrmij
3587                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3588                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3589 c               ees0mij1=0.0D0
3590                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3591                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3592                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3593                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3594                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3595                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3596                 ecosap=ecosa1+ecosa2
3597                 ecosbp=ecosb1+ecosb2
3598                 ecosgp=ecosg1+ecosg2
3599                 ecosam=ecosa1-ecosa2
3600                 ecosbm=ecosb1-ecosb2
3601                 ecosgm=ecosg1-ecosg2
3602 C Diagnostics
3603 c               ecosap=ecosa1
3604 c               ecosbp=ecosb1
3605 c               ecosgp=ecosg1
3606 c               ecosam=0.0D0
3607 c               ecosbm=0.0D0
3608 c               ecosgm=0.0D0
3609 C End diagnostics
3610                 facont_hb(num_conti,i)=fcont
3611                 fprimcont=fprimcont/rij
3612 cd              facont_hb(num_conti,i)=1.0D0
3613 C Following line is for diagnostics.
3614 cd              fprimcont=0.0D0
3615                 do k=1,3
3616                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3617                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3618                 enddo
3619                 do k=1,3
3620                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3621                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3622                 enddo
3623                 gggp(1)=gggp(1)+ees0pijp*xj
3624                 gggp(2)=gggp(2)+ees0pijp*yj
3625                 gggp(3)=gggp(3)+ees0pijp*zj
3626                 gggm(1)=gggm(1)+ees0mijp*xj
3627                 gggm(2)=gggm(2)+ees0mijp*yj
3628                 gggm(3)=gggm(3)+ees0mijp*zj
3629 C Derivatives due to the contact function
3630                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3631                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3632                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3633                 do k=1,3
3634 c
3635 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3636 c          following the change of gradient-summation algorithm.
3637 c
3638 cgrad                  ghalfp=0.5D0*gggp(k)
3639 cgrad                  ghalfm=0.5D0*gggm(k)
3640                   gacontp_hb1(k,num_conti,i)=!ghalfp
3641      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3642      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3643                   gacontp_hb2(k,num_conti,i)=!ghalfp
3644      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3645      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3646                   gacontp_hb3(k,num_conti,i)=gggp(k)
3647                   gacontm_hb1(k,num_conti,i)=!ghalfm
3648      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3649      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3650                   gacontm_hb2(k,num_conti,i)=!ghalfm
3651      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3652      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3653                   gacontm_hb3(k,num_conti,i)=gggm(k)
3654                 enddo
3655 C Diagnostics. Comment out or remove after debugging!
3656 cdiag           do k=1,3
3657 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3658 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3659 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3660 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3661 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3662 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3663 cdiag           enddo
3664               ENDIF ! wcorr
3665               endif  ! num_conti.le.maxconts
3666             endif  ! fcont.gt.0
3667           endif    ! j.gt.i+1
3668           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3669             do k=1,4
3670               do l=1,3
3671                 ghalf=0.5d0*agg(l,k)
3672                 aggi(l,k)=aggi(l,k)+ghalf
3673                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3674                 aggj(l,k)=aggj(l,k)+ghalf
3675               enddo
3676             enddo
3677             if (j.eq.nres-1 .and. i.lt.j-2) then
3678               do k=1,4
3679                 do l=1,3
3680                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3681                 enddo
3682               enddo
3683             endif
3684           endif
3685 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3686       return
3687       end
3688 C-----------------------------------------------------------------------------
3689       subroutine eturn3(i,eello_turn3)
3690 C Third- and fourth-order contributions from turns
3691       implicit real*8 (a-h,o-z)
3692       include 'DIMENSIONS'
3693       include 'COMMON.IOUNITS'
3694       include 'COMMON.GEO'
3695       include 'COMMON.VAR'
3696       include 'COMMON.LOCAL'
3697       include 'COMMON.CHAIN'
3698       include 'COMMON.DERIV'
3699       include 'COMMON.INTERACT'
3700       include 'COMMON.CONTACTS'
3701 #ifdef MOMENT
3702       include 'COMMON.CONTACTS.MOMENT'
3703 #endif
3704       include 'COMMON.TORSION'
3705       include 'COMMON.VECTORS'
3706       include 'COMMON.FFIELD'
3707       include 'COMMON.CONTROL'
3708       dimension ggg(3)
3709       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3710      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3711      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3712       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3713      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3714       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3715      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3716      &    num_conti,j1,j2
3717       j=i+2
3718 c      write (iout,*) "eturn3",i,j,j1,j2
3719       a_temp(1,1)=a22
3720       a_temp(1,2)=a23
3721       a_temp(2,1)=a32
3722       a_temp(2,2)=a33
3723 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3724 C
3725 C               Third-order contributions
3726 C
3727 C                 (i+2)o----(i+3)
3728 C                      | |
3729 C                      | |
3730 C                 (i+1)o----i
3731 C
3732 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3733 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3734         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3735         call transpose2(auxmat(1,1),auxmat1(1,1))
3736         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3737         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3738         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3739      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3740 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3741 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3742 cd     &    ' eello_turn3_num',4*eello_turn3_num
3743 C Derivatives in gamma(i)
3744         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3745         call transpose2(auxmat2(1,1),auxmat3(1,1))
3746         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3747         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3748 C Derivatives in gamma(i+1)
3749         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3750         call transpose2(auxmat2(1,1),auxmat3(1,1))
3751         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3752         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3753      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3754 C Cartesian derivatives
3755         do l=1,3
3756 c            ghalf1=0.5d0*agg(l,1)
3757 c            ghalf2=0.5d0*agg(l,2)
3758 c            ghalf3=0.5d0*agg(l,3)
3759 c            ghalf4=0.5d0*agg(l,4)
3760           a_temp(1,1)=aggi(l,1)!+ghalf1
3761           a_temp(1,2)=aggi(l,2)!+ghalf2
3762           a_temp(2,1)=aggi(l,3)!+ghalf3
3763           a_temp(2,2)=aggi(l,4)!+ghalf4
3764           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3765           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3766      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3767           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3768           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3769           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3770           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3771           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3772           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3773      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3774           a_temp(1,1)=aggj(l,1)!+ghalf1
3775           a_temp(1,2)=aggj(l,2)!+ghalf2
3776           a_temp(2,1)=aggj(l,3)!+ghalf3
3777           a_temp(2,2)=aggj(l,4)!+ghalf4
3778           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3779           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3780      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3781           a_temp(1,1)=aggj1(l,1)
3782           a_temp(1,2)=aggj1(l,2)
3783           a_temp(2,1)=aggj1(l,3)
3784           a_temp(2,2)=aggj1(l,4)
3785           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3786           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3787      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3788         enddo
3789       return
3790       end
3791 C-------------------------------------------------------------------------------
3792       subroutine eturn4(i,eello_turn4)
3793 C Third- and fourth-order contributions from turns
3794       implicit real*8 (a-h,o-z)
3795       include 'DIMENSIONS'
3796       include 'COMMON.IOUNITS'
3797       include 'COMMON.GEO'
3798       include 'COMMON.VAR'
3799       include 'COMMON.LOCAL'
3800       include 'COMMON.CHAIN'
3801       include 'COMMON.DERIV'
3802       include 'COMMON.INTERACT'
3803       include 'COMMON.CONTACTS'
3804 #ifdef MOMENT
3805       include 'COMMON.CONTACTS.MOMENT'
3806 #endif
3807       include 'COMMON.TORSION'
3808       include 'COMMON.VECTORS'
3809       include 'COMMON.FFIELD'
3810       include 'COMMON.CONTROL'
3811       dimension ggg(3)
3812       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3813      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3814      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3815       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3816      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3817       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3818      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3819      &    num_conti,j1,j2
3820       j=i+3
3821 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3822 C
3823 C               Fourth-order contributions
3824 C
3825 C                 (i+3)o----(i+4)
3826 C                     /  |
3827 C               (i+2)o   |
3828 C                     \  |
3829 C                 (i+1)o----i
3830 C
3831 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3832 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3833 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3834         a_temp(1,1)=a22
3835         a_temp(1,2)=a23
3836         a_temp(2,1)=a32
3837         a_temp(2,2)=a33
3838         iti1=itortyp(itype(i+1))
3839         iti2=itortyp(itype(i+2))
3840         iti3=itortyp(itype(i+3))
3841 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3842         call transpose2(EUg(1,1,i+1),e1t(1,1))
3843         call transpose2(Eug(1,1,i+2),e2t(1,1))
3844         call transpose2(Eug(1,1,i+3),e3t(1,1))
3845         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3846         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3847         s1=scalar2(b1(1,iti2),auxvec(1))
3848         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3849         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3850         s2=scalar2(b1(1,iti1),auxvec(1))
3851         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3852         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3853         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3854         eello_turn4=eello_turn4-(s1+s2+s3)
3855         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3856      &      'eturn4',i,j,-(s1+s2+s3)
3857 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3858 cd     &    ' eello_turn4_num',8*eello_turn4_num
3859 C Derivatives in gamma(i)
3860         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3861         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3862         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3863         s1=scalar2(b1(1,iti2),auxvec(1))
3864         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3865         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3866         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3867 C Derivatives in gamma(i+1)
3868         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3869         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3870         s2=scalar2(b1(1,iti1),auxvec(1))
3871         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3872         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3873         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3874         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3875 C Derivatives in gamma(i+2)
3876         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3877         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3878         s1=scalar2(b1(1,iti2),auxvec(1))
3879         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3880         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3881         s2=scalar2(b1(1,iti1),auxvec(1))
3882         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3883         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3884         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3885         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3886 C Cartesian derivatives
3887 C Derivatives of this turn contributions in DC(i+2)
3888         if (j.lt.nres-1) then
3889           do l=1,3
3890             a_temp(1,1)=agg(l,1)
3891             a_temp(1,2)=agg(l,2)
3892             a_temp(2,1)=agg(l,3)
3893             a_temp(2,2)=agg(l,4)
3894             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3895             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3896             s1=scalar2(b1(1,iti2),auxvec(1))
3897             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3898             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3899             s2=scalar2(b1(1,iti1),auxvec(1))
3900             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3901             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3902             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3903             ggg(l)=-(s1+s2+s3)
3904             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3905           enddo
3906         endif
3907 C Remaining derivatives of this turn contribution
3908         do l=1,3
3909           a_temp(1,1)=aggi(l,1)
3910           a_temp(1,2)=aggi(l,2)
3911           a_temp(2,1)=aggi(l,3)
3912           a_temp(2,2)=aggi(l,4)
3913           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3914           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3915           s1=scalar2(b1(1,iti2),auxvec(1))
3916           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3917           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3918           s2=scalar2(b1(1,iti1),auxvec(1))
3919           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3920           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3921           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3922           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3923           a_temp(1,1)=aggi1(l,1)
3924           a_temp(1,2)=aggi1(l,2)
3925           a_temp(2,1)=aggi1(l,3)
3926           a_temp(2,2)=aggi1(l,4)
3927           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3928           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3929           s1=scalar2(b1(1,iti2),auxvec(1))
3930           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3931           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3932           s2=scalar2(b1(1,iti1),auxvec(1))
3933           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3934           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3935           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3936           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3937           a_temp(1,1)=aggj(l,1)
3938           a_temp(1,2)=aggj(l,2)
3939           a_temp(2,1)=aggj(l,3)
3940           a_temp(2,2)=aggj(l,4)
3941           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3942           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3943           s1=scalar2(b1(1,iti2),auxvec(1))
3944           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3945           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3946           s2=scalar2(b1(1,iti1),auxvec(1))
3947           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3948           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3949           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3950           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3951           a_temp(1,1)=aggj1(l,1)
3952           a_temp(1,2)=aggj1(l,2)
3953           a_temp(2,1)=aggj1(l,3)
3954           a_temp(2,2)=aggj1(l,4)
3955           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3956           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3957           s1=scalar2(b1(1,iti2),auxvec(1))
3958           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3959           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3960           s2=scalar2(b1(1,iti1),auxvec(1))
3961           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3962           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3963           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3964 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3965           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3966         enddo
3967       return
3968       end
3969 C-----------------------------------------------------------------------------
3970       subroutine vecpr(u,v,w)
3971       implicit real*8(a-h,o-z)
3972       dimension u(3),v(3),w(3)
3973       w(1)=u(2)*v(3)-u(3)*v(2)
3974       w(2)=-u(1)*v(3)+u(3)*v(1)
3975       w(3)=u(1)*v(2)-u(2)*v(1)
3976       return
3977       end
3978 C-----------------------------------------------------------------------------
3979       subroutine unormderiv(u,ugrad,unorm,ungrad)
3980 C This subroutine computes the derivatives of a normalized vector u, given
3981 C the derivatives computed without normalization conditions, ugrad. Returns
3982 C ungrad.
3983       implicit none
3984       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3985       double precision vec(3)
3986       double precision scalar
3987       integer i,j
3988 c      write (2,*) 'ugrad',ugrad
3989 c      write (2,*) 'u',u
3990       do i=1,3
3991         vec(i)=scalar(ugrad(1,i),u(1))
3992       enddo
3993 c      write (2,*) 'vec',vec
3994       do i=1,3
3995         do j=1,3
3996           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3997         enddo
3998       enddo
3999 c      write (2,*) 'ungrad',ungrad
4000       return
4001       end
4002 C-----------------------------------------------------------------------------
4003       subroutine escp_soft_sphere(evdw2,evdw2_14)
4004 C
4005 C This subroutine calculates the excluded-volume interaction energy between
4006 C peptide-group centers and side chains and its gradient in virtual-bond and
4007 C side-chain vectors.
4008 C
4009       implicit real*8 (a-h,o-z)
4010       include 'DIMENSIONS'
4011       include 'COMMON.GEO'
4012       include 'COMMON.VAR'
4013       include 'COMMON.LOCAL'
4014       include 'COMMON.CHAIN'
4015       include 'COMMON.DERIV'
4016       include 'COMMON.INTERACT'
4017       include 'COMMON.FFIELD'
4018       include 'COMMON.IOUNITS'
4019       include 'COMMON.CONTROL'
4020       dimension ggg(3)
4021       evdw2=0.0D0
4022       evdw2_14=0.0d0
4023       r0_scp=4.5d0
4024 cd    print '(a)','Enter ESCP'
4025 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4026       do i=iatscp_s,iatscp_e
4027         iteli=itel(i)
4028         xi=0.5D0*(c(1,i)+c(1,i+1))
4029         yi=0.5D0*(c(2,i)+c(2,i+1))
4030         zi=0.5D0*(c(3,i)+c(3,i+1))
4031
4032         do iint=1,nscp_gr(i)
4033
4034         do j=iscpstart(i,iint),iscpend(i,iint)
4035           itypj=itype(j)
4036 C Uncomment following three lines for SC-p interactions
4037 c         xj=c(1,nres+j)-xi
4038 c         yj=c(2,nres+j)-yi
4039 c         zj=c(3,nres+j)-zi
4040 C Uncomment following three lines for Ca-p interactions
4041           xj=c(1,j)-xi
4042           yj=c(2,j)-yi
4043           zj=c(3,j)-zi
4044           rij=xj*xj+yj*yj+zj*zj
4045           r0ij=r0_scp
4046           r0ijsq=r0ij*r0ij
4047           if (rij.lt.r0ijsq) then
4048             evdwij=0.25d0*(rij-r0ijsq)**2
4049             fac=rij-r0ijsq
4050           else
4051             evdwij=0.0d0
4052             fac=0.0d0
4053           endif
4054           evdw2=evdw2+evdwij
4055 C
4056 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4057 C
4058           ggg(1)=xj*fac
4059           ggg(2)=yj*fac
4060           ggg(3)=zj*fac
4061 cgrad          if (j.lt.i) then
4062 cd          write (iout,*) 'j<i'
4063 C Uncomment following three lines for SC-p interactions
4064 c           do k=1,3
4065 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4066 c           enddo
4067 cgrad          else
4068 cd          write (iout,*) 'j>i'
4069 cgrad            do k=1,3
4070 cgrad              ggg(k)=-ggg(k)
4071 C Uncomment following line for SC-p interactions
4072 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4073 cgrad            enddo
4074 cgrad          endif
4075 cgrad          do k=1,3
4076 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4077 cgrad          enddo
4078 cgrad          kstart=min0(i+1,j)
4079 cgrad          kend=max0(i-1,j-1)
4080 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4081 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4082 cgrad          do k=kstart,kend
4083 cgrad            do l=1,3
4084 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4085 cgrad            enddo
4086 cgrad          enddo
4087           do k=1,3
4088             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4089             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4090           enddo
4091         enddo
4092
4093         enddo ! iint
4094       enddo ! i
4095       return
4096       end
4097 C-----------------------------------------------------------------------------
4098       subroutine escp(evdw2,evdw2_14)
4099 C
4100 C This subroutine calculates the excluded-volume interaction energy between
4101 C peptide-group centers and side chains and its gradient in virtual-bond and
4102 C side-chain vectors.
4103 C
4104       implicit real*8 (a-h,o-z)
4105       include 'DIMENSIONS'
4106       include 'COMMON.GEO'
4107       include 'COMMON.VAR'
4108       include 'COMMON.LOCAL'
4109       include 'COMMON.CHAIN'
4110       include 'COMMON.DERIV'
4111       include 'COMMON.INTERACT'
4112       include 'COMMON.FFIELD'
4113       include 'COMMON.IOUNITS'
4114       include 'COMMON.CONTROL'
4115       dimension ggg(3)
4116       evdw2=0.0D0
4117       evdw2_14=0.0d0
4118 cd    print '(a)','Enter ESCP'
4119 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4120       do i=iatscp_s,iatscp_e
4121         iteli=itel(i)
4122         xi=0.5D0*(c(1,i)+c(1,i+1))
4123         yi=0.5D0*(c(2,i)+c(2,i+1))
4124         zi=0.5D0*(c(3,i)+c(3,i+1))
4125
4126         do iint=1,nscp_gr(i)
4127
4128         do j=iscpstart(i,iint),iscpend(i,iint)
4129           itypj=itype(j)
4130 C Uncomment following three lines for SC-p interactions
4131 c         xj=c(1,nres+j)-xi
4132 c         yj=c(2,nres+j)-yi
4133 c         zj=c(3,nres+j)-zi
4134 C Uncomment following three lines for Ca-p interactions
4135           xj=c(1,j)-xi
4136           yj=c(2,j)-yi
4137           zj=c(3,j)-zi
4138           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4139           fac=rrij**expon2
4140           e1=fac*fac*aad(itypj,iteli)
4141           e2=fac*bad(itypj,iteli)
4142           if (iabs(j-i) .le. 2) then
4143             e1=scal14*e1
4144             e2=scal14*e2
4145             evdw2_14=evdw2_14+e1+e2
4146           endif
4147           evdwij=e1+e2
4148           evdw2=evdw2+evdwij
4149           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4150      &        'evdw2',i,j,evdwij
4151 C
4152 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4153 C
4154           fac=-(evdwij+e1)*rrij
4155           ggg(1)=xj*fac
4156           ggg(2)=yj*fac
4157           ggg(3)=zj*fac
4158 cgrad          if (j.lt.i) then
4159 cd          write (iout,*) 'j<i'
4160 C Uncomment following three lines for SC-p interactions
4161 c           do k=1,3
4162 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4163 c           enddo
4164 cgrad          else
4165 cd          write (iout,*) 'j>i'
4166 cgrad            do k=1,3
4167 cgrad              ggg(k)=-ggg(k)
4168 C Uncomment following line for SC-p interactions
4169 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4170 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4171 cgrad            enddo
4172 cgrad          endif
4173 cgrad          do k=1,3
4174 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4175 cgrad          enddo
4176 cgrad          kstart=min0(i+1,j)
4177 cgrad          kend=max0(i-1,j-1)
4178 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4179 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4180 cgrad          do k=kstart,kend
4181 cgrad            do l=1,3
4182 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4183 cgrad            enddo
4184 cgrad          enddo
4185           do k=1,3
4186             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4187             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4188           enddo
4189         enddo
4190
4191         enddo ! iint
4192       enddo ! i
4193       do i=1,nct
4194         do j=1,3
4195           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4196           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4197           gradx_scp(j,i)=expon*gradx_scp(j,i)
4198         enddo
4199       enddo
4200 C******************************************************************************
4201 C
4202 C                              N O T E !!!
4203 C
4204 C To save time the factor EXPON has been extracted from ALL components
4205 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4206 C use!
4207 C
4208 C******************************************************************************
4209       return
4210       end
4211 C--------------------------------------------------------------------------
4212       subroutine edis(ehpb)
4213 C
4214 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4215 C
4216       implicit real*8 (a-h,o-z)
4217       include 'DIMENSIONS'
4218       include 'COMMON.SBRIDGE'
4219       include 'COMMON.CHAIN'
4220       include 'COMMON.DERIV'
4221       include 'COMMON.VAR'
4222       include 'COMMON.INTERACT'
4223       include 'COMMON.IOUNITS'
4224       dimension ggg(3)
4225       ehpb=0.0D0
4226 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4227 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4228       if (link_end.eq.0) return
4229       do i=link_start,link_end
4230 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4231 C CA-CA distance used in regularization of structure.
4232         ii=ihpb(i)
4233         jj=jhpb(i)
4234 C iii and jjj point to the residues for which the distance is assigned.
4235         if (ii.gt.nres) then
4236           iii=ii-nres
4237           jjj=jj-nres
4238         else
4239           iii=ii
4240           jjj=jj
4241         endif
4242 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4243 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4244 C    distance and angle dependent SS bond potential.
4245         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4246           call ssbond_ene(iii,jjj,eij)
4247           ehpb=ehpb+2*eij
4248 cd          write (iout,*) "eij",eij
4249         else
4250 C Calculate the distance between the two points and its difference from the
4251 C target distance.
4252         dd=dist(ii,jj)
4253         rdis=dd-dhpb(i)
4254 C Get the force constant corresponding to this distance.
4255         waga=forcon(i)
4256 C Calculate the contribution to energy.
4257         ehpb=ehpb+waga*rdis*rdis
4258 C
4259 C Evaluate gradient.
4260 C
4261         fac=waga*rdis/dd
4262 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4263 cd   &   ' waga=',waga,' fac=',fac
4264         do j=1,3
4265           ggg(j)=fac*(c(j,jj)-c(j,ii))
4266         enddo
4267 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4268 C If this is a SC-SC distance, we need to calculate the contributions to the
4269 C Cartesian gradient in the SC vectors (ghpbx).
4270         if (iii.lt.ii) then
4271           do j=1,3
4272             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4273             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4274           enddo
4275         endif
4276 cgrad        do j=iii,jjj-1
4277 cgrad          do k=1,3
4278 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4279 cgrad          enddo
4280 cgrad        enddo
4281         do k=1,3
4282           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4283           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4284         enddo
4285         endif
4286       enddo
4287       ehpb=0.5D0*ehpb
4288       return
4289       end
4290 C--------------------------------------------------------------------------
4291       subroutine ssbond_ene(i,j,eij)
4292 C
4293 C Calculate the distance and angle dependent SS-bond potential energy
4294 C using a free-energy function derived based on RHF/6-31G** ab initio
4295 C calculations of diethyl disulfide.
4296 C
4297 C A. Liwo and U. Kozlowska, 11/24/03
4298 C
4299       implicit real*8 (a-h,o-z)
4300       include 'DIMENSIONS'
4301       include 'COMMON.SBRIDGE'
4302       include 'COMMON.CHAIN'
4303       include 'COMMON.DERIV'
4304       include 'COMMON.LOCAL'
4305       include 'COMMON.INTERACT'
4306       include 'COMMON.VAR'
4307       include 'COMMON.IOUNITS'
4308       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4309       itypi=itype(i)
4310       xi=c(1,nres+i)
4311       yi=c(2,nres+i)
4312       zi=c(3,nres+i)
4313       dxi=dc_norm(1,nres+i)
4314       dyi=dc_norm(2,nres+i)
4315       dzi=dc_norm(3,nres+i)
4316 c      dsci_inv=dsc_inv(itypi)
4317       dsci_inv=vbld_inv(nres+i)
4318       itypj=itype(j)
4319 c      dscj_inv=dsc_inv(itypj)
4320       dscj_inv=vbld_inv(nres+j)
4321       xj=c(1,nres+j)-xi
4322       yj=c(2,nres+j)-yi
4323       zj=c(3,nres+j)-zi
4324       dxj=dc_norm(1,nres+j)
4325       dyj=dc_norm(2,nres+j)
4326       dzj=dc_norm(3,nres+j)
4327       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4328       rij=dsqrt(rrij)
4329       erij(1)=xj*rij
4330       erij(2)=yj*rij
4331       erij(3)=zj*rij
4332       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4333       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4334       om12=dxi*dxj+dyi*dyj+dzi*dzj
4335       do k=1,3
4336         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4337         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4338       enddo
4339       rij=1.0d0/rij
4340       deltad=rij-d0cm
4341       deltat1=1.0d0-om1
4342       deltat2=1.0d0+om2
4343       deltat12=om2-om1+2.0d0
4344       cosphi=om12-om1*om2
4345       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4346      &  +akct*deltad*deltat12
4347      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4348 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4349 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4350 c     &  " deltat12",deltat12," eij",eij
4351       ed=2*akcm*deltad+akct*deltat12
4352       pom1=akct*deltad
4353       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4354       eom1=-2*akth*deltat1-pom1-om2*pom2
4355       eom2= 2*akth*deltat2+pom1-om1*pom2
4356       eom12=pom2
4357       do k=1,3
4358         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4359         ghpbx(k,i)=ghpbx(k,i)-ggk
4360      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4361      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4362         ghpbx(k,j)=ghpbx(k,j)+ggk
4363      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4364      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4365         ghpbc(k,i)=ghpbc(k,i)-ggk
4366         ghpbc(k,j)=ghpbc(k,j)+ggk
4367       enddo
4368 C
4369 C Calculate the components of the gradient in DC and X
4370 C
4371 cgrad      do k=i,j-1
4372 cgrad        do l=1,3
4373 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4374 cgrad        enddo
4375 cgrad      enddo
4376       return
4377       end
4378 C--------------------------------------------------------------------------
4379       subroutine ebond(estr)
4380 c
4381 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4382 c
4383       implicit real*8 (a-h,o-z)
4384       include 'DIMENSIONS'
4385       include 'COMMON.LOCAL'
4386       include 'COMMON.GEO'
4387       include 'COMMON.INTERACT'
4388       include 'COMMON.DERIV'
4389       include 'COMMON.VAR'
4390       include 'COMMON.CHAIN'
4391       include 'COMMON.IOUNITS'
4392       include 'COMMON.NAMES'
4393       include 'COMMON.FFIELD'
4394       include 'COMMON.CONTROL'
4395       include 'COMMON.SETUP'
4396       double precision u(3),ud(3)
4397       estr=0.0d0
4398       do i=ibondp_start,ibondp_end
4399         diff = vbld(i)-vbldp0
4400 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4401         estr=estr+diff*diff
4402         do j=1,3
4403           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4404         enddo
4405 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4406       enddo
4407       estr=0.5d0*AKP*estr
4408 c
4409 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4410 c
4411       do i=ibond_start,ibond_end
4412         iti=itype(i)
4413         if (iti.ne.10) then
4414           nbi=nbondterm(iti)
4415           if (nbi.eq.1) then
4416             diff=vbld(i+nres)-vbldsc0(1,iti)
4417 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4418 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4419             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4420             do j=1,3
4421               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4422             enddo
4423           else
4424             do j=1,nbi
4425               diff=vbld(i+nres)-vbldsc0(j,iti)
4426               ud(j)=aksc(j,iti)*diff
4427               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4428             enddo
4429             uprod=u(1)
4430             do j=2,nbi
4431               uprod=uprod*u(j)
4432             enddo
4433             usum=0.0d0
4434             usumsqder=0.0d0
4435             do j=1,nbi
4436               uprod1=1.0d0
4437               uprod2=1.0d0
4438               do k=1,nbi
4439                 if (k.ne.j) then
4440                   uprod1=uprod1*u(k)
4441                   uprod2=uprod2*u(k)*u(k)
4442                 endif
4443               enddo
4444               usum=usum+uprod1
4445               usumsqder=usumsqder+ud(j)*uprod2
4446             enddo
4447             estr=estr+uprod/usum
4448             do j=1,3
4449              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4450             enddo
4451           endif
4452         endif
4453       enddo
4454       return
4455       end
4456 #ifdef CRYST_THETA
4457 C--------------------------------------------------------------------------
4458       subroutine ebend(etheta)
4459 C
4460 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4461 C angles gamma and its derivatives in consecutive thetas and gammas.
4462 C
4463       implicit real*8 (a-h,o-z)
4464       include 'DIMENSIONS'
4465       include 'COMMON.LOCAL'
4466       include 'COMMON.GEO'
4467       include 'COMMON.INTERACT'
4468       include 'COMMON.DERIV'
4469       include 'COMMON.VAR'
4470       include 'COMMON.CHAIN'
4471       include 'COMMON.IOUNITS'
4472       include 'COMMON.NAMES'
4473       include 'COMMON.FFIELD'
4474       include 'COMMON.CONTROL'
4475       common /calcthet/ term1,term2,termm,diffak,ratak,
4476      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4477      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4478       double precision y(2),z(2)
4479       delta=0.02d0*pi
4480 c      time11=dexp(-2*time)
4481 c      time12=1.0d0
4482       etheta=0.0D0
4483 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4484       do i=ithet_start,ithet_end
4485 C Zero the energy function and its derivative at 0 or pi.
4486         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4487         it=itype(i-1)
4488         if (i.gt.3) then
4489 #ifdef OSF
4490           phii=phi(i)
4491           if (phii.ne.phii) phii=150.0
4492 #else
4493           phii=phi(i)
4494 #endif
4495           y(1)=dcos(phii)
4496           y(2)=dsin(phii)
4497         else
4498           y(1)=0.0D0
4499           y(2)=0.0D0
4500         endif
4501         if (i.lt.nres) then
4502 #ifdef OSF
4503           phii1=phi(i+1)
4504           if (phii1.ne.phii1) phii1=150.0
4505           phii1=pinorm(phii1)
4506           z(1)=cos(phii1)
4507 #else
4508           phii1=phi(i+1)
4509           z(1)=dcos(phii1)
4510 #endif
4511           z(2)=dsin(phii1)
4512         else
4513           z(1)=0.0D0
4514           z(2)=0.0D0
4515         endif
4516 C Calculate the "mean" value of theta from the part of the distribution
4517 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4518 C In following comments this theta will be referred to as t_c.
4519         thet_pred_mean=0.0d0
4520         do k=1,2
4521           athetk=athet(k,it)
4522           bthetk=bthet(k,it)
4523           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4524         enddo
4525         dthett=thet_pred_mean*ssd
4526         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4527 C Derivatives of the "mean" values in gamma1 and gamma2.
4528         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4529         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4530         if (theta(i).gt.pi-delta) then
4531           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4532      &         E_tc0)
4533           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4534           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4535           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4536      &        E_theta)
4537           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4538      &        E_tc)
4539         else if (theta(i).lt.delta) then
4540           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4541           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4542           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4543      &        E_theta)
4544           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4545           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4546      &        E_tc)
4547         else
4548           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4549      &        E_theta,E_tc)
4550         endif
4551         etheta=etheta+ethetai
4552         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4553      &      'ebend',i,ethetai
4554         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4555         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4556         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4557       enddo
4558 C Ufff.... We've done all this!!!
4559       return
4560       end
4561 C---------------------------------------------------------------------------
4562       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4563      &     E_tc)
4564       implicit real*8 (a-h,o-z)
4565       include 'DIMENSIONS'
4566       include 'COMMON.LOCAL'
4567       include 'COMMON.IOUNITS'
4568       common /calcthet/ term1,term2,termm,diffak,ratak,
4569      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4570      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4571 C Calculate the contributions to both Gaussian lobes.
4572 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4573 C The "polynomial part" of the "standard deviation" of this part of
4574 C the distribution.
4575         sig=polthet(3,it)
4576         do j=2,0,-1
4577           sig=sig*thet_pred_mean+polthet(j,it)
4578         enddo
4579 C Derivative of the "interior part" of the "standard deviation of the"
4580 C gamma-dependent Gaussian lobe in t_c.
4581         sigtc=3*polthet(3,it)
4582         do j=2,1,-1
4583           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4584         enddo
4585         sigtc=sig*sigtc
4586 C Set the parameters of both Gaussian lobes of the distribution.
4587 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4588         fac=sig*sig+sigc0(it)
4589         sigcsq=fac+fac
4590         sigc=1.0D0/sigcsq
4591 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4592         sigsqtc=-4.0D0*sigcsq*sigtc
4593 c       print *,i,sig,sigtc,sigsqtc
4594 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4595         sigtc=-sigtc/(fac*fac)
4596 C Following variable is sigma(t_c)**(-2)
4597         sigcsq=sigcsq*sigcsq
4598         sig0i=sig0(it)
4599         sig0inv=1.0D0/sig0i**2
4600         delthec=thetai-thet_pred_mean
4601         delthe0=thetai-theta0i
4602         term1=-0.5D0*sigcsq*delthec*delthec
4603         term2=-0.5D0*sig0inv*delthe0*delthe0
4604 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4605 C NaNs in taking the logarithm. We extract the largest exponent which is added
4606 C to the energy (this being the log of the distribution) at the end of energy
4607 C term evaluation for this virtual-bond angle.
4608         if (term1.gt.term2) then
4609           termm=term1
4610           term2=dexp(term2-termm)
4611           term1=1.0d0
4612         else
4613           termm=term2
4614           term1=dexp(term1-termm)
4615           term2=1.0d0
4616         endif
4617 C The ratio between the gamma-independent and gamma-dependent lobes of
4618 C the distribution is a Gaussian function of thet_pred_mean too.
4619         diffak=gthet(2,it)-thet_pred_mean
4620         ratak=diffak/gthet(3,it)**2
4621         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4622 C Let's differentiate it in thet_pred_mean NOW.
4623         aktc=ak*ratak
4624 C Now put together the distribution terms to make complete distribution.
4625         termexp=term1+ak*term2
4626         termpre=sigc+ak*sig0i
4627 C Contribution of the bending energy from this theta is just the -log of
4628 C the sum of the contributions from the two lobes and the pre-exponential
4629 C factor. Simple enough, isn't it?
4630         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4631 C NOW the derivatives!!!
4632 C 6/6/97 Take into account the deformation.
4633         E_theta=(delthec*sigcsq*term1
4634      &       +ak*delthe0*sig0inv*term2)/termexp
4635         E_tc=((sigtc+aktc*sig0i)/termpre
4636      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4637      &       aktc*term2)/termexp)
4638       return
4639       end
4640 c-----------------------------------------------------------------------------
4641       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4642       implicit real*8 (a-h,o-z)
4643       include 'DIMENSIONS'
4644       include 'COMMON.LOCAL'
4645       include 'COMMON.IOUNITS'
4646       common /calcthet/ term1,term2,termm,diffak,ratak,
4647      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4648      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4649       delthec=thetai-thet_pred_mean
4650       delthe0=thetai-theta0i
4651 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4652       t3 = thetai-thet_pred_mean
4653       t6 = t3**2
4654       t9 = term1
4655       t12 = t3*sigcsq
4656       t14 = t12+t6*sigsqtc
4657       t16 = 1.0d0
4658       t21 = thetai-theta0i
4659       t23 = t21**2
4660       t26 = term2
4661       t27 = t21*t26
4662       t32 = termexp
4663       t40 = t32**2
4664       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4665      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4666      & *(-t12*t9-ak*sig0inv*t27)
4667       return
4668       end
4669 #else
4670 C--------------------------------------------------------------------------
4671       subroutine ebend(etheta)
4672 C
4673 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4674 C angles gamma and its derivatives in consecutive thetas and gammas.
4675 C ab initio-derived potentials from
4676 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4677 C
4678       implicit real*8 (a-h,o-z)
4679       include 'DIMENSIONS'
4680       include 'COMMON.LOCAL'
4681       include 'COMMON.GEO'
4682       include 'COMMON.INTERACT'
4683       include 'COMMON.DERIV'
4684       include 'COMMON.VAR'
4685       include 'COMMON.CHAIN'
4686       include 'COMMON.IOUNITS'
4687       include 'COMMON.NAMES'
4688       include 'COMMON.FFIELD'
4689       include 'COMMON.CONTROL'
4690       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4691      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4692      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4693      & sinph1ph2(maxdouble,maxdouble)
4694       logical lprn /.false./, lprn1 /.false./
4695       etheta=0.0D0
4696       do i=ithet_start,ithet_end
4697         dethetai=0.0d0
4698         dephii=0.0d0
4699         dephii1=0.0d0
4700         theti2=0.5d0*theta(i)
4701         ityp2=ithetyp(itype(i-1))
4702         do k=1,nntheterm
4703           coskt(k)=dcos(k*theti2)
4704           sinkt(k)=dsin(k*theti2)
4705         enddo
4706         if (i.gt.3) then
4707 #ifdef OSF
4708           phii=phi(i)
4709           if (phii.ne.phii) phii=150.0
4710 #else
4711           phii=phi(i)
4712 #endif
4713           ityp1=ithetyp(itype(i-2))
4714           do k=1,nsingle
4715             cosph1(k)=dcos(k*phii)
4716             sinph1(k)=dsin(k*phii)
4717           enddo
4718         else
4719           phii=0.0d0
4720           ityp1=nthetyp+1
4721           do k=1,nsingle
4722             cosph1(k)=0.0d0
4723             sinph1(k)=0.0d0
4724           enddo
4725         endif
4726         if (i.lt.nres) then
4727 #ifdef OSF
4728           phii1=phi(i+1)
4729           if (phii1.ne.phii1) phii1=150.0
4730           phii1=pinorm(phii1)
4731 #else
4732           phii1=phi(i+1)
4733 #endif
4734           ityp3=ithetyp(itype(i))
4735           do k=1,nsingle
4736             cosph2(k)=dcos(k*phii1)
4737             sinph2(k)=dsin(k*phii1)
4738           enddo
4739         else
4740           phii1=0.0d0
4741           ityp3=nthetyp+1
4742           do k=1,nsingle
4743             cosph2(k)=0.0d0
4744             sinph2(k)=0.0d0
4745           enddo
4746         endif
4747         ethetai=aa0thet(ityp1,ityp2,ityp3)
4748         do k=1,ndouble
4749           do l=1,k-1
4750             ccl=cosph1(l)*cosph2(k-l)
4751             ssl=sinph1(l)*sinph2(k-l)
4752             scl=sinph1(l)*cosph2(k-l)
4753             csl=cosph1(l)*sinph2(k-l)
4754             cosph1ph2(l,k)=ccl-ssl
4755             cosph1ph2(k,l)=ccl+ssl
4756             sinph1ph2(l,k)=scl+csl
4757             sinph1ph2(k,l)=scl-csl
4758           enddo
4759         enddo
4760         if (lprn) then
4761         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4762      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4763         write (iout,*) "coskt and sinkt"
4764         do k=1,nntheterm
4765           write (iout,*) k,coskt(k),sinkt(k)
4766         enddo
4767         endif
4768         do k=1,ntheterm
4769           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4770           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4771      &      *coskt(k)
4772           if (lprn)
4773      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4774      &     " ethetai",ethetai
4775         enddo
4776         if (lprn) then
4777         write (iout,*) "cosph and sinph"
4778         do k=1,nsingle
4779           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4780         enddo
4781         write (iout,*) "cosph1ph2 and sinph2ph2"
4782         do k=2,ndouble
4783           do l=1,k-1
4784             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4785      &         sinph1ph2(l,k),sinph1ph2(k,l)
4786           enddo
4787         enddo
4788         write(iout,*) "ethetai",ethetai
4789         endif
4790         do m=1,ntheterm2
4791           do k=1,nsingle
4792             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4793      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4794      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4795      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4796             ethetai=ethetai+sinkt(m)*aux
4797             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4798             dephii=dephii+k*sinkt(m)*(
4799      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4800      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4801             dephii1=dephii1+k*sinkt(m)*(
4802      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4803      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4804             if (lprn)
4805      &      write (iout,*) "m",m," k",k," bbthet",
4806      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4807      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4808      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4809      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4810           enddo
4811         enddo
4812         if (lprn)
4813      &  write(iout,*) "ethetai",ethetai
4814         do m=1,ntheterm3
4815           do k=2,ndouble
4816             do l=1,k-1
4817               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4818      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4819      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4820      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4821               ethetai=ethetai+sinkt(m)*aux
4822               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4823               dephii=dephii+l*sinkt(m)*(
4824      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4825      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4826      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4827      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4828               dephii1=dephii1+(k-l)*sinkt(m)*(
4829      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4830      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4831      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4832      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4833               if (lprn) then
4834               write (iout,*) "m",m," k",k," l",l," ffthet",
4835      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4836      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4837      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4838      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4839               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4840      &            cosph1ph2(k,l)*sinkt(m),
4841      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4842               endif
4843             enddo
4844           enddo
4845         enddo
4846 10      continue
4847         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4848      &   i,theta(i)*rad2deg,phii*rad2deg,
4849      &   phii1*rad2deg,ethetai
4850         etheta=etheta+ethetai
4851         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4852         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4853         gloc(nphi+i-2,icg)=wang*dethetai
4854       enddo
4855       return
4856       end
4857 #endif
4858 #ifdef CRYST_SC
4859 c-----------------------------------------------------------------------------
4860       subroutine esc(escloc)
4861 C Calculate the local energy of a side chain and its derivatives in the
4862 C corresponding virtual-bond valence angles THETA and the spherical angles
4863 C ALPHA and OMEGA.
4864       implicit real*8 (a-h,o-z)
4865       include 'DIMENSIONS'
4866       include 'COMMON.GEO'
4867       include 'COMMON.LOCAL'
4868       include 'COMMON.VAR'
4869       include 'COMMON.INTERACT'
4870       include 'COMMON.DERIV'
4871       include 'COMMON.CHAIN'
4872       include 'COMMON.IOUNITS'
4873       include 'COMMON.NAMES'
4874       include 'COMMON.FFIELD'
4875       include 'COMMON.CONTROL'
4876       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4877      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4878       common /sccalc/ time11,time12,time112,theti,it,nlobit
4879       delta=0.02d0*pi
4880       escloc=0.0D0
4881 c     write (iout,'(a)') 'ESC'
4882       do i=loc_start,loc_end
4883         it=itype(i)
4884         if (it.eq.10) goto 1
4885         nlobit=nlob(it)
4886 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4887 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4888         theti=theta(i+1)-pipol
4889         x(1)=dtan(theti)
4890         x(2)=alph(i)
4891         x(3)=omeg(i)
4892
4893         if (x(2).gt.pi-delta) then
4894           xtemp(1)=x(1)
4895           xtemp(2)=pi-delta
4896           xtemp(3)=x(3)
4897           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4898           xtemp(2)=pi
4899           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4900           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4901      &        escloci,dersc(2))
4902           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4903      &        ddersc0(1),dersc(1))
4904           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4905      &        ddersc0(3),dersc(3))
4906           xtemp(2)=pi-delta
4907           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4908           xtemp(2)=pi
4909           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4910           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4911      &            dersc0(2),esclocbi,dersc02)
4912           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4913      &            dersc12,dersc01)
4914           call splinthet(x(2),0.5d0*delta,ss,ssd)
4915           dersc0(1)=dersc01
4916           dersc0(2)=dersc02
4917           dersc0(3)=0.0d0
4918           do k=1,3
4919             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4920           enddo
4921           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4922 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4923 c    &             esclocbi,ss,ssd
4924           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4925 c         escloci=esclocbi
4926 c         write (iout,*) escloci
4927         else if (x(2).lt.delta) then
4928           xtemp(1)=x(1)
4929           xtemp(2)=delta
4930           xtemp(3)=x(3)
4931           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4932           xtemp(2)=0.0d0
4933           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4934           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4935      &        escloci,dersc(2))
4936           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4937      &        ddersc0(1),dersc(1))
4938           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4939      &        ddersc0(3),dersc(3))
4940           xtemp(2)=delta
4941           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4942           xtemp(2)=0.0d0
4943           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4944           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4945      &            dersc0(2),esclocbi,dersc02)
4946           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4947      &            dersc12,dersc01)
4948           dersc0(1)=dersc01
4949           dersc0(2)=dersc02
4950           dersc0(3)=0.0d0
4951           call splinthet(x(2),0.5d0*delta,ss,ssd)
4952           do k=1,3
4953             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4954           enddo
4955           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4956 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4957 c    &             esclocbi,ss,ssd
4958           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4959 c         write (iout,*) escloci
4960         else
4961           call enesc(x,escloci,dersc,ddummy,.false.)
4962         endif
4963
4964         escloc=escloc+escloci
4965         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4966      &     'escloc',i,escloci
4967 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4968
4969         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4970      &   wscloc*dersc(1)
4971         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4972         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4973     1   continue
4974       enddo
4975       return
4976       end
4977 C---------------------------------------------------------------------------
4978       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4979       implicit real*8 (a-h,o-z)
4980       include 'DIMENSIONS'
4981       include 'COMMON.GEO'
4982       include 'COMMON.LOCAL'
4983       include 'COMMON.IOUNITS'
4984       common /sccalc/ time11,time12,time112,theti,it,nlobit
4985       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4986       double precision contr(maxlob,-1:1)
4987       logical mixed
4988 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4989         escloc_i=0.0D0
4990         do j=1,3
4991           dersc(j)=0.0D0
4992           if (mixed) ddersc(j)=0.0d0
4993         enddo
4994         x3=x(3)
4995
4996 C Because of periodicity of the dependence of the SC energy in omega we have
4997 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4998 C To avoid underflows, first compute & store the exponents.
4999
5000         do iii=-1,1
5001
5002           x(3)=x3+iii*dwapi
5003
5004           do j=1,nlobit
5005             do k=1,3
5006               z(k)=x(k)-censc(k,j,it)
5007             enddo
5008             do k=1,3
5009               Axk=0.0D0
5010               do l=1,3
5011                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5012               enddo
5013               Ax(k,j,iii)=Axk
5014             enddo
5015             expfac=0.0D0
5016             do k=1,3
5017               expfac=expfac+Ax(k,j,iii)*z(k)
5018             enddo
5019             contr(j,iii)=expfac
5020           enddo ! j
5021
5022         enddo ! iii
5023
5024         x(3)=x3
5025 C As in the case of ebend, we want to avoid underflows in exponentiation and
5026 C subsequent NaNs and INFs in energy calculation.
5027 C Find the largest exponent
5028         emin=contr(1,-1)
5029         do iii=-1,1
5030           do j=1,nlobit
5031             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5032           enddo
5033         enddo
5034         emin=0.5D0*emin
5035 cd      print *,'it=',it,' emin=',emin
5036
5037 C Compute the contribution to SC energy and derivatives
5038         do iii=-1,1
5039
5040           do j=1,nlobit
5041 #ifdef OSF
5042             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5043             if(adexp.ne.adexp) adexp=1.0
5044             expfac=dexp(adexp)
5045 #else
5046             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5047 #endif
5048 cd          print *,'j=',j,' expfac=',expfac
5049             escloc_i=escloc_i+expfac
5050             do k=1,3
5051               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5052             enddo
5053             if (mixed) then
5054               do k=1,3,2
5055                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5056      &            +gaussc(k,2,j,it))*expfac
5057               enddo
5058             endif
5059           enddo
5060
5061         enddo ! iii
5062
5063         dersc(1)=dersc(1)/cos(theti)**2
5064         ddersc(1)=ddersc(1)/cos(theti)**2
5065         ddersc(3)=ddersc(3)
5066
5067         escloci=-(dlog(escloc_i)-emin)
5068         do j=1,3
5069           dersc(j)=dersc(j)/escloc_i
5070         enddo
5071         if (mixed) then
5072           do j=1,3,2
5073             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5074           enddo
5075         endif
5076       return
5077       end
5078 C------------------------------------------------------------------------------
5079       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5080       implicit real*8 (a-h,o-z)
5081       include 'DIMENSIONS'
5082       include 'COMMON.GEO'
5083       include 'COMMON.LOCAL'
5084       include 'COMMON.IOUNITS'
5085       common /sccalc/ time11,time12,time112,theti,it,nlobit
5086       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5087       double precision contr(maxlob)
5088       logical mixed
5089
5090       escloc_i=0.0D0
5091
5092       do j=1,3
5093         dersc(j)=0.0D0
5094       enddo
5095
5096       do j=1,nlobit
5097         do k=1,2
5098           z(k)=x(k)-censc(k,j,it)
5099         enddo
5100         z(3)=dwapi
5101         do k=1,3
5102           Axk=0.0D0
5103           do l=1,3
5104             Axk=Axk+gaussc(l,k,j,it)*z(l)
5105           enddo
5106           Ax(k,j)=Axk
5107         enddo
5108         expfac=0.0D0
5109         do k=1,3
5110           expfac=expfac+Ax(k,j)*z(k)
5111         enddo
5112         contr(j)=expfac
5113       enddo ! j
5114
5115 C As in the case of ebend, we want to avoid underflows in exponentiation and
5116 C subsequent NaNs and INFs in energy calculation.
5117 C Find the largest exponent
5118       emin=contr(1)
5119       do j=1,nlobit
5120         if (emin.gt.contr(j)) emin=contr(j)
5121       enddo
5122       emin=0.5D0*emin
5123
5124 C Compute the contribution to SC energy and derivatives
5125
5126       dersc12=0.0d0
5127       do j=1,nlobit
5128         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5129         escloc_i=escloc_i+expfac
5130         do k=1,2
5131           dersc(k)=dersc(k)+Ax(k,j)*expfac
5132         enddo
5133         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5134      &            +gaussc(1,2,j,it))*expfac
5135         dersc(3)=0.0d0
5136       enddo
5137
5138       dersc(1)=dersc(1)/cos(theti)**2
5139       dersc12=dersc12/cos(theti)**2
5140       escloci=-(dlog(escloc_i)-emin)
5141       do j=1,2
5142         dersc(j)=dersc(j)/escloc_i
5143       enddo
5144       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5145       return
5146       end
5147 #else
5148 c----------------------------------------------------------------------------------
5149       subroutine esc(escloc)
5150 C Calculate the local energy of a side chain and its derivatives in the
5151 C corresponding virtual-bond valence angles THETA and the spherical angles
5152 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5153 C added by Urszula Kozlowska. 07/11/2007
5154 C
5155       implicit real*8 (a-h,o-z)
5156       include 'DIMENSIONS'
5157       include 'COMMON.GEO'
5158       include 'COMMON.LOCAL'
5159       include 'COMMON.VAR'
5160       include 'COMMON.SCROT'
5161       include 'COMMON.INTERACT'
5162       include 'COMMON.DERIV'
5163       include 'COMMON.CHAIN'
5164       include 'COMMON.IOUNITS'
5165       include 'COMMON.NAMES'
5166       include 'COMMON.FFIELD'
5167       include 'COMMON.CONTROL'
5168       include 'COMMON.VECTORS'
5169       double precision x_prime(3),y_prime(3),z_prime(3)
5170      &    , sumene,dsc_i,dp2_i,x(65),
5171      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5172      &    de_dxx,de_dyy,de_dzz,de_dt
5173       double precision s1_t,s1_6_t,s2_t,s2_6_t
5174       double precision
5175      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5176      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5177      & dt_dCi(3),dt_dCi1(3)
5178       common /sccalc/ time11,time12,time112,theti,it,nlobit
5179       delta=0.02d0*pi
5180       escloc=0.0D0
5181       do i=loc_start,loc_end
5182         costtab(i+1) =dcos(theta(i+1))
5183         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5184         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5185         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5186         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5187         cosfac=dsqrt(cosfac2)
5188         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5189         sinfac=dsqrt(sinfac2)
5190         it=itype(i)
5191         if (it.eq.10) goto 1
5192 c
5193 C  Compute the axes of tghe local cartesian coordinates system; store in
5194 c   x_prime, y_prime and z_prime
5195 c
5196         do j=1,3
5197           x_prime(j) = 0.00
5198           y_prime(j) = 0.00
5199           z_prime(j) = 0.00
5200         enddo
5201 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5202 C     &   dc_norm(3,i+nres)
5203         do j = 1,3
5204           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5205           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5206         enddo
5207         do j = 1,3
5208           z_prime(j) = -uz(j,i-1)
5209         enddo
5210 c       write (2,*) "i",i
5211 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5212 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5213 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5214 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5215 c      & " xy",scalar(x_prime(1),y_prime(1)),
5216 c      & " xz",scalar(x_prime(1),z_prime(1)),
5217 c      & " yy",scalar(y_prime(1),y_prime(1)),
5218 c      & " yz",scalar(y_prime(1),z_prime(1)),
5219 c      & " zz",scalar(z_prime(1),z_prime(1))
5220 c
5221 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5222 C to local coordinate system. Store in xx, yy, zz.
5223 c
5224         xx=0.0d0
5225         yy=0.0d0
5226         zz=0.0d0
5227         do j = 1,3
5228           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5229           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5230           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5231         enddo
5232
5233         xxtab(i)=xx
5234         yytab(i)=yy
5235         zztab(i)=zz
5236 C
5237 C Compute the energy of the ith side cbain
5238 C
5239 c        write (2,*) "xx",xx," yy",yy," zz",zz
5240         it=itype(i)
5241         do j = 1,65
5242           x(j) = sc_parmin(j,it)
5243         enddo
5244 #ifdef CHECK_COORD
5245 Cc diagnostics - remove later
5246         xx1 = dcos(alph(2))
5247         yy1 = dsin(alph(2))*dcos(omeg(2))
5248         zz1 = -dsin(alph(2))*dsin(omeg(2))
5249         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5250      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5251      &    xx1,yy1,zz1
5252 C,"  --- ", xx_w,yy_w,zz_w
5253 c end diagnostics
5254 #endif
5255         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5256      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5257      &   + x(10)*yy*zz
5258         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5259      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5260      & + x(20)*yy*zz
5261         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5262      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5263      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5264      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5265      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5266      &  +x(40)*xx*yy*zz
5267         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5268      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5269      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5270      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5271      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5272      &  +x(60)*xx*yy*zz
5273         dsc_i   = 0.743d0+x(61)
5274         dp2_i   = 1.9d0+x(62)
5275         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5276      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5277         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5278      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5279         s1=(1+x(63))/(0.1d0 + dscp1)
5280         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5281         s2=(1+x(65))/(0.1d0 + dscp2)
5282         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5283         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5284      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5285 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5286 c     &   sumene4,
5287 c     &   dscp1,dscp2,sumene
5288 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5289         escloc = escloc + sumene
5290 c        write (2,*) "i",i," escloc",sumene,escloc
5291 #ifdef DEBUG
5292 C
5293 C This section to check the numerical derivatives of the energy of ith side
5294 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5295 C #define DEBUG in the code to turn it on.
5296 C
5297         write (2,*) "sumene               =",sumene
5298         aincr=1.0d-7
5299         xxsave=xx
5300         xx=xx+aincr
5301         write (2,*) xx,yy,zz
5302         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5303         de_dxx_num=(sumenep-sumene)/aincr
5304         xx=xxsave
5305         write (2,*) "xx+ sumene from enesc=",sumenep
5306         yysave=yy
5307         yy=yy+aincr
5308         write (2,*) xx,yy,zz
5309         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5310         de_dyy_num=(sumenep-sumene)/aincr
5311         yy=yysave
5312         write (2,*) "yy+ sumene from enesc=",sumenep
5313         zzsave=zz
5314         zz=zz+aincr
5315         write (2,*) xx,yy,zz
5316         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5317         de_dzz_num=(sumenep-sumene)/aincr
5318         zz=zzsave
5319         write (2,*) "zz+ sumene from enesc=",sumenep
5320         costsave=cost2tab(i+1)
5321         sintsave=sint2tab(i+1)
5322         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5323         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5324         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5325         de_dt_num=(sumenep-sumene)/aincr
5326         write (2,*) " t+ sumene from enesc=",sumenep
5327         cost2tab(i+1)=costsave
5328         sint2tab(i+1)=sintsave
5329 C End of diagnostics section.
5330 #endif
5331 C
5332 C Compute the gradient of esc
5333 C
5334         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5335         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5336         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5337         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5338         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5339         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5340         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5341         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5342         pom1=(sumene3*sint2tab(i+1)+sumene1)
5343      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5344         pom2=(sumene4*cost2tab(i+1)+sumene2)
5345      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5346         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5347         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5348      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5349      &  +x(40)*yy*zz
5350         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5351         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5352      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5353      &  +x(60)*yy*zz
5354         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5355      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5356      &        +(pom1+pom2)*pom_dx
5357 #ifdef DEBUG
5358         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5359 #endif
5360 C
5361         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5362         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5363      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5364      &  +x(40)*xx*zz
5365         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5366         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5367      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5368      &  +x(59)*zz**2 +x(60)*xx*zz
5369         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5370      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5371      &        +(pom1-pom2)*pom_dy
5372 #ifdef DEBUG
5373         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5374 #endif
5375 C
5376         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5377      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5378      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5379      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5380      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5381      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5382      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5383      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5384 #ifdef DEBUG
5385         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5386 #endif
5387 C
5388         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5389      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5390      &  +pom1*pom_dt1+pom2*pom_dt2
5391 #ifdef DEBUG
5392         write(2,*), "de_dt = ", de_dt,de_dt_num
5393 #endif
5394 c
5395 C
5396        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5397        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5398        cosfac2xx=cosfac2*xx
5399        sinfac2yy=sinfac2*yy
5400        do k = 1,3
5401          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5402      &      vbld_inv(i+1)
5403          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5404      &      vbld_inv(i)
5405          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5406          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5407 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5408 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5409 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5410 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5411          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5412          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5413          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5414          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5415          dZZ_Ci1(k)=0.0d0
5416          dZZ_Ci(k)=0.0d0
5417          do j=1,3
5418            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5419            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5420          enddo
5421
5422          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5423          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5424          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5425 c
5426          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5427          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5428        enddo
5429
5430        do k=1,3
5431          dXX_Ctab(k,i)=dXX_Ci(k)
5432          dXX_C1tab(k,i)=dXX_Ci1(k)
5433          dYY_Ctab(k,i)=dYY_Ci(k)
5434          dYY_C1tab(k,i)=dYY_Ci1(k)
5435          dZZ_Ctab(k,i)=dZZ_Ci(k)
5436          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5437          dXX_XYZtab(k,i)=dXX_XYZ(k)
5438          dYY_XYZtab(k,i)=dYY_XYZ(k)
5439          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5440        enddo
5441
5442        do k = 1,3
5443 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5444 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5445 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5446 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5447 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5448 c     &    dt_dci(k)
5449 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5450 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5451          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5452      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5453          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5454      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5455          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5456      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5457        enddo
5458 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5459 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5460
5461 C to check gradient call subroutine check_grad
5462
5463     1 continue
5464       enddo
5465       return
5466       end
5467 c------------------------------------------------------------------------------
5468       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5469       implicit none
5470       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5471      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5472       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5473      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5474      &   + x(10)*yy*zz
5475       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5476      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5477      & + x(20)*yy*zz
5478       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5479      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5480      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5481      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5482      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5483      &  +x(40)*xx*yy*zz
5484       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5485      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5486      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5487      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5488      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5489      &  +x(60)*xx*yy*zz
5490       dsc_i   = 0.743d0+x(61)
5491       dp2_i   = 1.9d0+x(62)
5492       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5493      &          *(xx*cost2+yy*sint2))
5494       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5495      &          *(xx*cost2-yy*sint2))
5496       s1=(1+x(63))/(0.1d0 + dscp1)
5497       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5498       s2=(1+x(65))/(0.1d0 + dscp2)
5499       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5500       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5501      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5502       enesc=sumene
5503       return
5504       end
5505 #endif
5506 c------------------------------------------------------------------------------
5507       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5508 C
5509 C This procedure calculates two-body contact function g(rij) and its derivative:
5510 C
5511 C           eps0ij                                     !       x < -1
5512 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5513 C            0                                         !       x > 1
5514 C
5515 C where x=(rij-r0ij)/delta
5516 C
5517 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5518 C
5519       implicit none
5520       double precision rij,r0ij,eps0ij,fcont,fprimcont
5521       double precision x,x2,x4,delta
5522 c     delta=0.02D0*r0ij
5523 c      delta=0.2D0*r0ij
5524       x=(rij-r0ij)/delta
5525       if (x.lt.-1.0D0) then
5526         fcont=eps0ij
5527         fprimcont=0.0D0
5528       else if (x.le.1.0D0) then
5529         x2=x*x
5530         x4=x2*x2
5531         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5532         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5533       else
5534         fcont=0.0D0
5535         fprimcont=0.0D0
5536       endif
5537       return
5538       end
5539 c------------------------------------------------------------------------------
5540       subroutine splinthet(theti,delta,ss,ssder)
5541       implicit real*8 (a-h,o-z)
5542       include 'DIMENSIONS'
5543       include 'COMMON.VAR'
5544       include 'COMMON.GEO'
5545       thetup=pi-delta
5546       thetlow=delta
5547       if (theti.gt.pipol) then
5548         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5549       else
5550         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5551         ssder=-ssder
5552       endif
5553       return
5554       end
5555 c------------------------------------------------------------------------------
5556       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5557       implicit none
5558       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5559       double precision ksi,ksi2,ksi3,a1,a2,a3
5560       a1=fprim0*delta/(f1-f0)
5561       a2=3.0d0-2.0d0*a1
5562       a3=a1-2.0d0
5563       ksi=(x-x0)/delta
5564       ksi2=ksi*ksi
5565       ksi3=ksi2*ksi
5566       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5567       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5568       return
5569       end
5570 c------------------------------------------------------------------------------
5571       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5572       implicit none
5573       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5574       double precision ksi,ksi2,ksi3,a1,a2,a3
5575       ksi=(x-x0)/delta
5576       ksi2=ksi*ksi
5577       ksi3=ksi2*ksi
5578       a1=fprim0x*delta
5579       a2=3*(f1x-f0x)-2*fprim0x*delta
5580       a3=fprim0x*delta-2*(f1x-f0x)
5581       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5582       return
5583       end
5584 C-----------------------------------------------------------------------------
5585 #ifdef CRYST_TOR
5586 C-----------------------------------------------------------------------------
5587       subroutine etor(etors,edihcnstr)
5588       implicit real*8 (a-h,o-z)
5589       include 'DIMENSIONS'
5590       include 'COMMON.VAR'
5591       include 'COMMON.GEO'
5592       include 'COMMON.LOCAL'
5593       include 'COMMON.TORSION'
5594       include 'COMMON.INTERACT'
5595       include 'COMMON.DERIV'
5596       include 'COMMON.CHAIN'
5597       include 'COMMON.NAMES'
5598       include 'COMMON.IOUNITS'
5599       include 'COMMON.FFIELD'
5600       include 'COMMON.TORCNSTR'
5601       include 'COMMON.CONTROL'
5602       logical lprn
5603 C Set lprn=.true. for debugging
5604       lprn=.false.
5605 c      lprn=.true.
5606       etors=0.0D0
5607       do i=iphi_start,iphi_end
5608       etors_ii=0.0D0
5609         itori=itortyp(itype(i-2))
5610         itori1=itortyp(itype(i-1))
5611         phii=phi(i)
5612         gloci=0.0D0
5613 C Proline-Proline pair is a special case...
5614         if (itori.eq.3 .and. itori1.eq.3) then
5615           if (phii.gt.-dwapi3) then
5616             cosphi=dcos(3*phii)
5617             fac=1.0D0/(1.0D0-cosphi)
5618             etorsi=v1(1,3,3)*fac
5619             etorsi=etorsi+etorsi
5620             etors=etors+etorsi-v1(1,3,3)
5621             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5622             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5623           endif
5624           do j=1,3
5625             v1ij=v1(j+1,itori,itori1)
5626             v2ij=v2(j+1,itori,itori1)
5627             cosphi=dcos(j*phii)
5628             sinphi=dsin(j*phii)
5629             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5630             if (energy_dec) etors_ii=etors_ii+
5631      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5632             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5633           enddo
5634         else
5635           do j=1,nterm_old
5636             v1ij=v1(j,itori,itori1)
5637             v2ij=v2(j,itori,itori1)
5638             cosphi=dcos(j*phii)
5639             sinphi=dsin(j*phii)
5640             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5641             if (energy_dec) etors_ii=etors_ii+
5642      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5643             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5644           enddo
5645         endif
5646         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5647      &        'etor',i,etors_ii
5648         if (lprn)
5649      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5650      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5651      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5652         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5653 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5654       enddo
5655 ! 6/20/98 - dihedral angle constraints
5656       edihcnstr=0.0d0
5657       do i=1,ndih_constr
5658         itori=idih_constr(i)
5659         phii=phi(itori)
5660         difi=phii-phi0(i)
5661         if (difi.gt.drange(i)) then
5662           difi=difi-drange(i)
5663           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5664           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5665         else if (difi.lt.-drange(i)) then
5666           difi=difi+drange(i)
5667           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5668           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5669         endif
5670 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5671 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5672       enddo
5673 !      write (iout,*) 'edihcnstr',edihcnstr
5674       return
5675       end
5676 c------------------------------------------------------------------------------
5677       subroutine etor_d(etors_d)
5678       etors_d=0.0d0
5679       return
5680       end
5681 c----------------------------------------------------------------------------
5682 #else
5683       subroutine etor(etors,edihcnstr)
5684       implicit real*8 (a-h,o-z)
5685       include 'DIMENSIONS'
5686       include 'COMMON.VAR'
5687       include 'COMMON.GEO'
5688       include 'COMMON.LOCAL'
5689       include 'COMMON.TORSION'
5690       include 'COMMON.INTERACT'
5691       include 'COMMON.DERIV'
5692       include 'COMMON.CHAIN'
5693       include 'COMMON.NAMES'
5694       include 'COMMON.IOUNITS'
5695       include 'COMMON.FFIELD'
5696       include 'COMMON.TORCNSTR'
5697       include 'COMMON.CONTROL'
5698       logical lprn
5699 C Set lprn=.true. for debugging
5700       lprn=.false.
5701 c     lprn=.true.
5702       etors=0.0D0
5703       do i=iphi_start,iphi_end
5704       etors_ii=0.0D0
5705         itori=itortyp(itype(i-2))
5706         itori1=itortyp(itype(i-1))
5707         phii=phi(i)
5708         gloci=0.0D0
5709 C Regular cosine and sine terms
5710         do j=1,nterm(itori,itori1)
5711           v1ij=v1(j,itori,itori1)
5712           v2ij=v2(j,itori,itori1)
5713           cosphi=dcos(j*phii)
5714           sinphi=dsin(j*phii)
5715           etors=etors+v1ij*cosphi+v2ij*sinphi
5716           if (energy_dec) etors_ii=etors_ii+
5717      &                v1ij*cosphi+v2ij*sinphi
5718           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5719         enddo
5720 C Lorentz terms
5721 C                         v1
5722 C  E = SUM ----------------------------------- - v1
5723 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5724 C
5725         cosphi=dcos(0.5d0*phii)
5726         sinphi=dsin(0.5d0*phii)
5727         do j=1,nlor(itori,itori1)
5728           vl1ij=vlor1(j,itori,itori1)
5729           vl2ij=vlor2(j,itori,itori1)
5730           vl3ij=vlor3(j,itori,itori1)
5731           pom=vl2ij*cosphi+vl3ij*sinphi
5732           pom1=1.0d0/(pom*pom+1.0d0)
5733           etors=etors+vl1ij*pom1
5734           if (energy_dec) etors_ii=etors_ii+
5735      &                vl1ij*pom1
5736           pom=-pom*pom1*pom1
5737           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5738         enddo
5739 C Subtract the constant term
5740         etors=etors-v0(itori,itori1)
5741           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5742      &         'etor',i,etors_ii-v0(itori,itori1)
5743         if (lprn)
5744      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5745      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5746      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5747         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5748 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5749       enddo
5750 ! 6/20/98 - dihedral angle constraints
5751       edihcnstr=0.0d0
5752 c      do i=1,ndih_constr
5753       do i=idihconstr_start,idihconstr_end
5754         itori=idih_constr(i)
5755         phii=phi(itori)
5756         difi=pinorm(phii-phi0(i))
5757         if (difi.gt.drange(i)) then
5758           difi=difi-drange(i)
5759           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5760           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5761         else if (difi.lt.-drange(i)) then
5762           difi=difi+drange(i)
5763           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5764           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5765         else
5766           difi=0.0
5767         endif
5768 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5769 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5770 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5771       enddo
5772 cd       write (iout,*) 'edihcnstr',edihcnstr
5773       return
5774       end
5775 c----------------------------------------------------------------------------
5776       subroutine etor_d(etors_d)
5777 C 6/23/01 Compute double torsional energy
5778       implicit real*8 (a-h,o-z)
5779       include 'DIMENSIONS'
5780       include 'COMMON.VAR'
5781       include 'COMMON.GEO'
5782       include 'COMMON.LOCAL'
5783       include 'COMMON.TORSION'
5784       include 'COMMON.INTERACT'
5785       include 'COMMON.DERIV'
5786       include 'COMMON.CHAIN'
5787       include 'COMMON.NAMES'
5788       include 'COMMON.IOUNITS'
5789       include 'COMMON.FFIELD'
5790       include 'COMMON.TORCNSTR'
5791       logical lprn
5792 C Set lprn=.true. for debugging
5793       lprn=.false.
5794 c     lprn=.true.
5795       etors_d=0.0D0
5796       do i=iphid_start,iphid_end
5797         itori=itortyp(itype(i-2))
5798         itori1=itortyp(itype(i-1))
5799         itori2=itortyp(itype(i))
5800         phii=phi(i)
5801         phii1=phi(i+1)
5802         gloci1=0.0D0
5803         gloci2=0.0D0
5804 C Regular cosine and sine terms
5805         do j=1,ntermd_1(itori,itori1,itori2)
5806           v1cij=v1c(1,j,itori,itori1,itori2)
5807           v1sij=v1s(1,j,itori,itori1,itori2)
5808           v2cij=v1c(2,j,itori,itori1,itori2)
5809           v2sij=v1s(2,j,itori,itori1,itori2)
5810           cosphi1=dcos(j*phii)
5811           sinphi1=dsin(j*phii)
5812           cosphi2=dcos(j*phii1)
5813           sinphi2=dsin(j*phii1)
5814           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5815      &     v2cij*cosphi2+v2sij*sinphi2
5816           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5817           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5818         enddo
5819         do k=2,ntermd_2(itori,itori1,itori2)
5820           do l=1,k-1
5821             v1cdij = v2c(k,l,itori,itori1,itori2)
5822             v2cdij = v2c(l,k,itori,itori1,itori2)
5823             v1sdij = v2s(k,l,itori,itori1,itori2)
5824             v2sdij = v2s(l,k,itori,itori1,itori2)
5825             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5826             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5827             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5828             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5829             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5830      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5831             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5832      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5833             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5834      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5835           enddo
5836         enddo
5837         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5838         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5839       enddo
5840       return
5841       end
5842 #endif
5843 c------------------------------------------------------------------------------
5844       subroutine eback_sc_corr(esccor)
5845 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5846 c        conformational states; temporarily implemented as differences
5847 c        between UNRES torsional potentials (dependent on three types of
5848 c        residues) and the torsional potentials dependent on all 20 types
5849 c        of residues computed from AM1  energy surfaces of terminally-blocked
5850 c        amino-acid residues.
5851       implicit real*8 (a-h,o-z)
5852       include 'DIMENSIONS'
5853       include 'COMMON.VAR'
5854       include 'COMMON.GEO'
5855       include 'COMMON.LOCAL'
5856       include 'COMMON.TORSION'
5857       include 'COMMON.SCCOR'
5858       include 'COMMON.INTERACT'
5859       include 'COMMON.DERIV'
5860       include 'COMMON.CHAIN'
5861       include 'COMMON.NAMES'
5862       include 'COMMON.IOUNITS'
5863       include 'COMMON.FFIELD'
5864       include 'COMMON.CONTROL'
5865       logical lprn
5866 C Set lprn=.true. for debugging
5867       lprn=.false.
5868 c      lprn=.true.
5869 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5870       esccor=0.0D0
5871       do i=itau_start,itau_end
5872         esccor_ii=0.0D0
5873         isccori=isccortyp(itype(i-2))
5874         isccori1=isccortyp(itype(i-1))
5875 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5876         phii=phi(i)
5877         do intertyp=1,3 !intertyp
5878 cc Added 09 May 2012 (Adasko)
5879 cc  Intertyp means interaction type of backbone mainchain correlation:
5880 c   1 = SC...Ca...Ca...Ca
5881 c   2 = Ca...Ca...Ca...SC
5882 c   3 = SC...Ca...Ca...SCi
5883         gloci=0.0D0
5884         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5885      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5886      &      (itype(i-1).eq.ntyp1)))
5887      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5888      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5889      &     .or.(itype(i).eq.ntyp1)))
5890      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5891      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5892      &      (itype(i-3).eq.ntyp1)))) cycle
5893         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5894         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5895      & cycle
5896        do j=1,nterm_sccor(isccori,isccori1)
5897           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5898           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5899           cosphi=dcos(j*tauangle(intertyp,i))
5900           sinphi=dsin(j*tauangle(intertyp,i))
5901           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5902           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5903         enddo
5904 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
5905         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5906         if (lprn)
5907      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5908      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5909      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5910      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5911 C        gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5912        enddo !intertyp
5913       enddo
5914
5915       return
5916       end
5917 c----------------------------------------------------------------------------
5918       subroutine multibody(ecorr)
5919 C This subroutine calculates multi-body contributions to energy following
5920 C the idea of Skolnick et al. If side chains I and J make a contact and
5921 C at the same time side chains I+1 and J+1 make a contact, an extra
5922 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5923       implicit real*8 (a-h,o-z)
5924       include 'DIMENSIONS'
5925       include 'COMMON.IOUNITS'
5926       include 'COMMON.DERIV'
5927       include 'COMMON.INTERACT'
5928       include 'COMMON.CONTACTS'
5929 #ifdef MOMENT
5930       include 'COMMON.CONTACTS.MOMENT'
5931 #endif
5932       double precision gx(3),gx1(3)
5933       logical lprn
5934
5935 C Set lprn=.true. for debugging
5936       lprn=.false.
5937
5938       if (lprn) then
5939         write (iout,'(a)') 'Contact function values:'
5940         do i=nnt,nct-2
5941           write (iout,'(i2,20(1x,i2,f10.5))')
5942      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5943         enddo
5944       endif
5945       ecorr=0.0D0
5946       do i=nnt,nct
5947         do j=1,3
5948           gradcorr(j,i)=0.0D0
5949           gradxorr(j,i)=0.0D0
5950         enddo
5951       enddo
5952       do i=nnt,nct-2
5953
5954         DO ISHIFT = 3,4
5955
5956         i1=i+ishift
5957         num_conti=num_cont(i)
5958         num_conti1=num_cont(i1)
5959         do jj=1,num_conti
5960           j=jcont(jj,i)
5961           do kk=1,num_conti1
5962             j1=jcont(kk,i1)
5963             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5964 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5965 cd   &                   ' ishift=',ishift
5966 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5967 C The system gains extra energy.
5968               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5969             endif   ! j1==j+-ishift
5970           enddo     ! kk
5971         enddo       ! jj
5972
5973         ENDDO ! ISHIFT
5974
5975       enddo         ! i
5976       return
5977       end
5978 c------------------------------------------------------------------------------
5979       double precision function esccorr(i,j,k,l,jj,kk)
5980       implicit real*8 (a-h,o-z)
5981       include 'DIMENSIONS'
5982       include 'COMMON.IOUNITS'
5983       include 'COMMON.DERIV'
5984       include 'COMMON.INTERACT'
5985       include 'COMMON.CONTACTS'
5986 #ifdef MOMENT
5987       include 'COMMON.CONTACTS.MOMENT'
5988 #endif
5989       double precision gx(3),gx1(3)
5990       logical lprn
5991       lprn=.false.
5992       eij=facont(jj,i)
5993       ekl=facont(kk,k)
5994 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5995 C Calculate the multi-body contribution to energy.
5996 C Calculate multi-body contributions to the gradient.
5997 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5998 cd   & k,l,(gacont(m,kk,k),m=1,3)
5999       do m=1,3
6000         gx(m) =ekl*gacont(m,jj,i)
6001         gx1(m)=eij*gacont(m,kk,k)
6002         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6003         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6004         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6005         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6006       enddo
6007       do m=i,j-1
6008         do ll=1,3
6009           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6010         enddo
6011       enddo
6012       do m=k,l-1
6013         do ll=1,3
6014           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6015         enddo
6016       enddo
6017       esccorr=-eij*ekl
6018       return
6019       end
6020 c------------------------------------------------------------------------------
6021       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6022 C This subroutine calculates multi-body contributions to hydrogen-bonding
6023       implicit real*8 (a-h,o-z)
6024       include 'DIMENSIONS'
6025       include 'COMMON.IOUNITS'
6026 #ifdef MPI
6027       include "mpif.h"
6028       parameter (max_cont=maxconts)
6029       parameter (max_dim=26)
6030       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6031       double precision zapas(max_dim,maxconts,max_fg_procs),
6032      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6033       common /przechowalnia/ zapas
6034       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6035      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6036 #endif
6037       include 'COMMON.SETUP'
6038       include 'COMMON.FFIELD'
6039       include 'COMMON.DERIV'
6040       include 'COMMON.INTERACT'
6041       include 'COMMON.CONTACTS'
6042 #ifdef MOMENT
6043       include 'COMMON.CONTACTS.MOMENT'
6044 #endif
6045       include 'COMMON.CONTROL'
6046       include 'COMMON.LOCAL'
6047       double precision gx(3),gx1(3),time00
6048       logical lprn,ldone
6049
6050 C Set lprn=.true. for debugging
6051       lprn=.false.
6052 #ifdef MPI
6053       n_corr=0
6054       n_corr1=0
6055       if (nfgtasks.le.1) goto 30
6056       if (lprn) then
6057         write (iout,'(a)') 'Contact function values before RECEIVE:'
6058         do i=nnt,nct-2
6059           write (iout,'(2i3,50(1x,i2,f5.2))')
6060      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6061      &    j=1,num_cont_hb(i))
6062         enddo
6063       endif
6064       call flush(iout)
6065       do i=1,ntask_cont_from
6066         ncont_recv(i)=0
6067       enddo
6068       do i=1,ntask_cont_to
6069         ncont_sent(i)=0
6070       enddo
6071 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6072 c     & ntask_cont_to
6073 C Make the list of contacts to send to send to other procesors
6074 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6075 c      call flush(iout)
6076       do i=iturn3_start,iturn3_end
6077 c        write (iout,*) "make contact list turn3",i," num_cont",
6078 c     &    num_cont_hb(i)
6079         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6080       enddo
6081       do i=iturn4_start,iturn4_end
6082 c        write (iout,*) "make contact list turn4",i," num_cont",
6083 c     &   num_cont_hb(i)
6084         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6085       enddo
6086       do ii=1,nat_sent
6087         i=iat_sent(ii)
6088 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6089 c     &    num_cont_hb(i)
6090         do j=1,num_cont_hb(i)
6091         do k=1,4
6092           jjc=jcont_hb(j,i)
6093           iproc=iint_sent_local(k,jjc,ii)
6094 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6095           if (iproc.gt.0) then
6096             ncont_sent(iproc)=ncont_sent(iproc)+1
6097             nn=ncont_sent(iproc)
6098             zapas(1,nn,iproc)=i
6099             zapas(2,nn,iproc)=jjc
6100             zapas(3,nn,iproc)=facont_hb(j,i)
6101             zapas(4,nn,iproc)=ees0p(j,i)
6102             zapas(5,nn,iproc)=ees0m(j,i)
6103             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6104             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6105             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6106             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6107             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6108             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6109             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6110             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6111             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6112             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6113             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6114             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6115             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6116             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6117             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6118             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6119             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6120             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6121             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6122             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6123             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6124           endif
6125         enddo
6126         enddo
6127       enddo
6128       if (lprn) then
6129       write (iout,*)
6130      &  "Numbers of contacts to be sent to other processors",
6131      &  (ncont_sent(i),i=1,ntask_cont_to)
6132       write (iout,*) "Contacts sent"
6133       do ii=1,ntask_cont_to
6134         nn=ncont_sent(ii)
6135         iproc=itask_cont_to(ii)
6136         write (iout,*) nn," contacts to processor",iproc,
6137      &   " of CONT_TO_COMM group"
6138         do i=1,nn
6139           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6140         enddo
6141       enddo
6142       call flush(iout)
6143       endif
6144       CorrelType=477
6145       CorrelID=fg_rank+1
6146       CorrelType1=478
6147       CorrelID1=nfgtasks+fg_rank+1
6148       ireq=0
6149 C Receive the numbers of needed contacts from other processors
6150       do ii=1,ntask_cont_from
6151         iproc=itask_cont_from(ii)
6152         ireq=ireq+1
6153         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6154      &    FG_COMM,req(ireq),IERR)
6155       enddo
6156 c      write (iout,*) "IRECV ended"
6157 c      call flush(iout)
6158 C Send the number of contacts needed by other processors
6159       do ii=1,ntask_cont_to
6160         iproc=itask_cont_to(ii)
6161         ireq=ireq+1
6162         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6163      &    FG_COMM,req(ireq),IERR)
6164       enddo
6165 c      write (iout,*) "ISEND ended"
6166 c      write (iout,*) "number of requests (nn)",ireq
6167       call flush(iout)
6168       if (ireq.gt.0)
6169      &  call MPI_Waitall(ireq,req,status_array,ierr)
6170 c      write (iout,*)
6171 c     &  "Numbers of contacts to be received from other processors",
6172 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6173 c      call flush(iout)
6174 C Receive contacts
6175       ireq=0
6176       do ii=1,ntask_cont_from
6177         iproc=itask_cont_from(ii)
6178         nn=ncont_recv(ii)
6179 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6180 c     &   " of CONT_TO_COMM group"
6181         call flush(iout)
6182         if (nn.gt.0) then
6183           ireq=ireq+1
6184           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6185      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6186 c          write (iout,*) "ireq,req",ireq,req(ireq)
6187         endif
6188       enddo
6189 C Send the contacts to processors that need them
6190       do ii=1,ntask_cont_to
6191         iproc=itask_cont_to(ii)
6192         nn=ncont_sent(ii)
6193 c        write (iout,*) nn," contacts to processor",iproc,
6194 c     &   " of CONT_TO_COMM group"
6195         if (nn.gt.0) then
6196           ireq=ireq+1
6197           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6198      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6199 c          write (iout,*) "ireq,req",ireq,req(ireq)
6200 c          do i=1,nn
6201 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6202 c          enddo
6203         endif
6204       enddo
6205 c      write (iout,*) "number of requests (contacts)",ireq
6206 c      write (iout,*) "req",(req(i),i=1,4)
6207 c      call flush(iout)
6208       if (ireq.gt.0)
6209      & call MPI_Waitall(ireq,req,status_array,ierr)
6210       do iii=1,ntask_cont_from
6211         iproc=itask_cont_from(iii)
6212         nn=ncont_recv(iii)
6213         if (lprn) then
6214         write (iout,*) "Received",nn," contacts from processor",iproc,
6215      &   " of CONT_FROM_COMM group"
6216         call flush(iout)
6217         do i=1,nn
6218           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6219         enddo
6220         call flush(iout)
6221         endif
6222         do i=1,nn
6223           ii=zapas_recv(1,i,iii)
6224 c Flag the received contacts to prevent double-counting
6225           jj=-zapas_recv(2,i,iii)
6226 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6227 c          call flush(iout)
6228           nnn=num_cont_hb(ii)+1
6229           num_cont_hb(ii)=nnn
6230           jcont_hb(nnn,ii)=jj
6231           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6232           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6233           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6234           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6235           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6236           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6237           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6238           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6239           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6240           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6241           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6242           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6243           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6244           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6245           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6246           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6247           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6248           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6249           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6250           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6251           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6252           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6253           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6254           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6255         enddo
6256       enddo
6257       call flush(iout)
6258       if (lprn) then
6259         write (iout,'(a)') 'Contact function values after receive:'
6260         do i=nnt,nct-2
6261           write (iout,'(2i3,50(1x,i3,f5.2))')
6262      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6263      &    j=1,num_cont_hb(i))
6264         enddo
6265         call flush(iout)
6266       endif
6267    30 continue
6268 #endif
6269       if (lprn) then
6270         write (iout,'(a)') 'Contact function values:'
6271         do i=nnt,nct-2
6272           write (iout,'(2i3,50(1x,i3,f5.2))')
6273      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6274      &    j=1,num_cont_hb(i))
6275         enddo
6276       endif
6277       ecorr=0.0D0
6278 C Remove the loop below after debugging !!!
6279       do i=nnt,nct
6280         do j=1,3
6281           gradcorr(j,i)=0.0D0
6282           gradxorr(j,i)=0.0D0
6283         enddo
6284       enddo
6285 C Calculate the local-electrostatic correlation terms
6286       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6287         i1=i+1
6288         num_conti=num_cont_hb(i)
6289         num_conti1=num_cont_hb(i+1)
6290         do jj=1,num_conti
6291           j=jcont_hb(jj,i)
6292           jp=iabs(j)
6293           do kk=1,num_conti1
6294             j1=jcont_hb(kk,i1)
6295             jp1=iabs(j1)
6296 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6297 c     &         ' jj=',jj,' kk=',kk
6298             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6299      &          .or. j.lt.0 .and. j1.gt.0) .and.
6300      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6301 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6302 C The system gains extra energy.
6303               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6304               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6305      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6306               n_corr=n_corr+1
6307             else if (j1.eq.j) then
6308 C Contacts I-J and I-(J+1) occur simultaneously.
6309 C The system loses extra energy.
6310 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6311             endif
6312           enddo ! kk
6313           do kk=1,num_conti
6314             j1=jcont_hb(kk,i)
6315 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6316 c    &         ' jj=',jj,' kk=',kk
6317             if (j1.eq.j+1) then
6318 C Contacts I-J and (I+1)-J occur simultaneously.
6319 C The system loses extra energy.
6320 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6321             endif ! j1==j+1
6322           enddo ! kk
6323         enddo ! jj
6324       enddo ! i
6325       return
6326       end
6327 c------------------------------------------------------------------------------
6328       subroutine add_hb_contact(ii,jj,itask)
6329       implicit real*8 (a-h,o-z)
6330       include "DIMENSIONS"
6331       include "COMMON.IOUNITS"
6332       integer max_cont
6333       integer max_dim
6334       parameter (max_cont=maxconts)
6335       parameter (max_dim=26)
6336       include "COMMON.CONTACTS"
6337 #ifdef MOMENT
6338       include 'COMMON.CONTACTS.MOMENT'
6339 #endif
6340       double precision zapas(max_dim,maxconts,max_fg_procs),
6341      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6342       common /przechowalnia/ zapas
6343       integer i,j,ii,jj,iproc,itask(4),nn
6344 c      write (iout,*) "itask",itask
6345       do i=1,2
6346         iproc=itask(i)
6347         if (iproc.gt.0) then
6348           do j=1,num_cont_hb(ii)
6349             jjc=jcont_hb(j,ii)
6350 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6351             if (jjc.eq.jj) then
6352               ncont_sent(iproc)=ncont_sent(iproc)+1
6353               nn=ncont_sent(iproc)
6354               zapas(1,nn,iproc)=ii
6355               zapas(2,nn,iproc)=jjc
6356               zapas(3,nn,iproc)=facont_hb(j,ii)
6357               zapas(4,nn,iproc)=ees0p(j,ii)
6358               zapas(5,nn,iproc)=ees0m(j,ii)
6359               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6360               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6361               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6362               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6363               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6364               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6365               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6366               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6367               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6368               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6369               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6370               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6371               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6372               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6373               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6374               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6375               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6376               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6377               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6378               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6379               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6380               exit
6381             endif
6382           enddo
6383         endif
6384       enddo
6385       return
6386       end
6387 c------------------------------------------------------------------------------
6388       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6389      &  n_corr1)
6390 C This subroutine calculates multi-body contributions to hydrogen-bonding
6391       implicit real*8 (a-h,o-z)
6392       include 'DIMENSIONS'
6393       include 'COMMON.IOUNITS'
6394 #ifdef MPI
6395       include "mpif.h"
6396       parameter (max_cont=maxconts)
6397       parameter (max_dim=70)
6398       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6399       double precision zapas(max_dim,maxconts,max_fg_procs),
6400      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6401       common /przechowalnia/ zapas
6402       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6403      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6404 #endif
6405       include 'COMMON.SETUP'
6406       include 'COMMON.FFIELD'
6407       include 'COMMON.DERIV'
6408       include 'COMMON.LOCAL'
6409       include 'COMMON.INTERACT'
6410       include 'COMMON.CONTACTS'
6411 #ifdef MOMENT
6412       include 'COMMON.CONTACTS.MOMENT'
6413 #endif
6414       include 'COMMON.CHAIN'
6415       include 'COMMON.CONTROL'
6416       double precision gx(3),gx1(3)
6417       integer num_cont_hb_old(maxres)
6418       logical lprn,ldone
6419       double precision eello4,eello5,eelo6,eello_turn6
6420       external eello4,eello5,eello6,eello_turn6
6421 C Set lprn=.true. for debugging
6422       lprn=.false.
6423       eturn6=0.0d0
6424 #ifdef MPI
6425       do i=1,nres
6426         num_cont_hb_old(i)=num_cont_hb(i)
6427       enddo
6428       n_corr=0
6429       n_corr1=0
6430       if (nfgtasks.le.1) goto 30
6431       if (lprn) then
6432         write (iout,'(a)') 'Contact function values before RECEIVE:'
6433         do i=nnt,nct-2
6434           write (iout,'(2i3,50(1x,i2,f5.2))')
6435      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6436      &    j=1,num_cont_hb(i))
6437         enddo
6438       endif
6439       call flush(iout)
6440       do i=1,ntask_cont_from
6441         ncont_recv(i)=0
6442       enddo
6443       do i=1,ntask_cont_to
6444         ncont_sent(i)=0
6445       enddo
6446 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6447 c     & ntask_cont_to
6448 C Make the list of contacts to send to send to other procesors
6449       do i=iturn3_start,iturn3_end
6450 c        write (iout,*) "make contact list turn3",i," num_cont",
6451 c     &    num_cont_hb(i)
6452         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6453       enddo
6454       do i=iturn4_start,iturn4_end
6455 c        write (iout,*) "make contact list turn4",i," num_cont",
6456 c     &   num_cont_hb(i)
6457         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6458       enddo
6459       do ii=1,nat_sent
6460         i=iat_sent(ii)
6461 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6462 c     &    num_cont_hb(i)
6463         do j=1,num_cont_hb(i)
6464         do k=1,4
6465           jjc=jcont_hb(j,i)
6466           iproc=iint_sent_local(k,jjc,ii)
6467 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6468           if (iproc.ne.0) then
6469             ncont_sent(iproc)=ncont_sent(iproc)+1
6470             nn=ncont_sent(iproc)
6471             zapas(1,nn,iproc)=i
6472             zapas(2,nn,iproc)=jjc
6473             zapas(3,nn,iproc)=d_cont(j,i)
6474             ind=3
6475             do kk=1,3
6476               ind=ind+1
6477               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6478             enddo
6479             do kk=1,2
6480               do ll=1,2
6481                 ind=ind+1
6482                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6483               enddo
6484             enddo
6485             do jj=1,5
6486               do kk=1,3
6487                 do ll=1,2
6488                   do mm=1,2
6489                     ind=ind+1
6490                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6491                   enddo
6492                 enddo
6493               enddo
6494             enddo
6495           endif
6496         enddo
6497         enddo
6498       enddo
6499       if (lprn) then
6500       write (iout,*)
6501      &  "Numbers of contacts to be sent to other processors",
6502      &  (ncont_sent(i),i=1,ntask_cont_to)
6503       write (iout,*) "Contacts sent"
6504       do ii=1,ntask_cont_to
6505         nn=ncont_sent(ii)
6506         iproc=itask_cont_to(ii)
6507         write (iout,*) nn," contacts to processor",iproc,
6508      &   " of CONT_TO_COMM group"
6509         do i=1,nn
6510           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6511         enddo
6512       enddo
6513       call flush(iout)
6514       endif
6515       CorrelType=477
6516       CorrelID=fg_rank+1
6517       CorrelType1=478
6518       CorrelID1=nfgtasks+fg_rank+1
6519       ireq=0
6520 C Receive the numbers of needed contacts from other processors
6521       do ii=1,ntask_cont_from
6522         iproc=itask_cont_from(ii)
6523         ireq=ireq+1
6524         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6525      &    FG_COMM,req(ireq),IERR)
6526       enddo
6527 c      write (iout,*) "IRECV ended"
6528 c      call flush(iout)
6529 C Send the number of contacts needed by other processors
6530       do ii=1,ntask_cont_to
6531         iproc=itask_cont_to(ii)
6532         ireq=ireq+1
6533         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6534      &    FG_COMM,req(ireq),IERR)
6535       enddo
6536 c      write (iout,*) "ISEND ended"
6537 c      write (iout,*) "number of requests (nn)",ireq
6538       call flush(iout)
6539       if (ireq.gt.0)
6540      &  call MPI_Waitall(ireq,req,status_array,ierr)
6541 c      write (iout,*)
6542 c     &  "Numbers of contacts to be received from other processors",
6543 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6544 c      call flush(iout)
6545 C Receive contacts
6546       ireq=0
6547       do ii=1,ntask_cont_from
6548         iproc=itask_cont_from(ii)
6549         nn=ncont_recv(ii)
6550 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6551 c     &   " of CONT_TO_COMM group"
6552         call flush(iout)
6553         if (nn.gt.0) then
6554           ireq=ireq+1
6555           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6556      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6557 c          write (iout,*) "ireq,req",ireq,req(ireq)
6558         endif
6559       enddo
6560 C Send the contacts to processors that need them
6561       do ii=1,ntask_cont_to
6562         iproc=itask_cont_to(ii)
6563         nn=ncont_sent(ii)
6564 c        write (iout,*) nn," contacts to processor",iproc,
6565 c     &   " of CONT_TO_COMM group"
6566         if (nn.gt.0) then
6567           ireq=ireq+1
6568           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6569      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6570 c          write (iout,*) "ireq,req",ireq,req(ireq)
6571 c          do i=1,nn
6572 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6573 c          enddo
6574         endif
6575       enddo
6576 c      write (iout,*) "number of requests (contacts)",ireq
6577 c      write (iout,*) "req",(req(i),i=1,4)
6578 c      call flush(iout)
6579       if (ireq.gt.0)
6580      & call MPI_Waitall(ireq,req,status_array,ierr)
6581       do iii=1,ntask_cont_from
6582         iproc=itask_cont_from(iii)
6583         nn=ncont_recv(iii)
6584         if (lprn) then
6585         write (iout,*) "Received",nn," contacts from processor",iproc,
6586      &   " of CONT_FROM_COMM group"
6587         call flush(iout)
6588         do i=1,nn
6589           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6590         enddo
6591         call flush(iout)
6592         endif
6593         do i=1,nn
6594           ii=zapas_recv(1,i,iii)
6595 c Flag the received contacts to prevent double-counting
6596           jj=-zapas_recv(2,i,iii)
6597 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6598 c          call flush(iout)
6599           nnn=num_cont_hb(ii)+1
6600           num_cont_hb(ii)=nnn
6601           jcont_hb(nnn,ii)=jj
6602           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6603           ind=3
6604           do kk=1,3
6605             ind=ind+1
6606             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6607           enddo
6608           do kk=1,2
6609             do ll=1,2
6610               ind=ind+1
6611               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6612             enddo
6613           enddo
6614           do jj=1,5
6615             do kk=1,3
6616               do ll=1,2
6617                 do mm=1,2
6618                   ind=ind+1
6619                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6620                 enddo
6621               enddo
6622             enddo
6623           enddo
6624         enddo
6625       enddo
6626       call flush(iout)
6627       if (lprn) then
6628         write (iout,'(a)') 'Contact function values after receive:'
6629         do i=nnt,nct-2
6630           write (iout,'(2i3,50(1x,i3,5f6.3))')
6631      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6632      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6633         enddo
6634         call flush(iout)
6635       endif
6636    30 continue
6637 #endif
6638       if (lprn) then
6639         write (iout,'(a)') 'Contact function values:'
6640         do i=nnt,nct-2
6641           write (iout,'(2i3,50(1x,i2,5f6.3))')
6642      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6643      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6644         enddo
6645       endif
6646       ecorr=0.0D0
6647       ecorr5=0.0d0
6648       ecorr6=0.0d0
6649 C Remove the loop below after debugging !!!
6650       do i=nnt,nct
6651         do j=1,3
6652           gradcorr(j,i)=0.0D0
6653           gradxorr(j,i)=0.0D0
6654         enddo
6655       enddo
6656 C Calculate the dipole-dipole interaction energies
6657       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6658       do i=iatel_s,iatel_e+1
6659         num_conti=num_cont_hb(i)
6660         do jj=1,num_conti
6661           j=jcont_hb(jj,i)
6662 #ifdef MOMENT
6663           call dipole(i,j,jj)
6664 #endif
6665         enddo
6666       enddo
6667       endif
6668 C Calculate the local-electrostatic correlation terms
6669 c                write (iout,*) "gradcorr5 in eello5 before loop"
6670 c                do iii=1,nres
6671 c                  write (iout,'(i5,3f10.5)')
6672 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6673 c                enddo
6674       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6675 c        write (iout,*) "corr loop i",i
6676         i1=i+1
6677         num_conti=num_cont_hb(i)
6678         num_conti1=num_cont_hb(i+1)
6679         do jj=1,num_conti
6680           j=jcont_hb(jj,i)
6681           jp=iabs(j)
6682           do kk=1,num_conti1
6683             j1=jcont_hb(kk,i1)
6684             jp1=iabs(j1)
6685 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6686 c     &         ' jj=',jj,' kk=',kk
6687 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6688             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6689      &          .or. j.lt.0 .and. j1.gt.0) .and.
6690      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6691 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6692 C The system gains extra energy.
6693               n_corr=n_corr+1
6694               sqd1=dsqrt(d_cont(jj,i))
6695               sqd2=dsqrt(d_cont(kk,i1))
6696               sred_geom = sqd1*sqd2
6697               IF (sred_geom.lt.cutoff_corr) THEN
6698                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6699      &            ekont,fprimcont)
6700 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6701 cd     &         ' jj=',jj,' kk=',kk
6702                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6703                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6704                 do l=1,3
6705                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6706                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6707                 enddo
6708                 n_corr1=n_corr1+1
6709 cd               write (iout,*) 'sred_geom=',sred_geom,
6710 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6711 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6712 cd               write (iout,*) "g_contij",g_contij
6713 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6714 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6715                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6716                 if (wcorr4.gt.0.0d0)
6717      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6718                   if (energy_dec.and.wcorr4.gt.0.0d0)
6719      1                 write (iout,'(a6,4i5,0pf7.3)')
6720      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6721 c                write (iout,*) "gradcorr5 before eello5"
6722 c                do iii=1,nres
6723 c                  write (iout,'(i5,3f10.5)')
6724 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6725 c                enddo
6726                 if (wcorr5.gt.0.0d0)
6727      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6728 c                write (iout,*) "gradcorr5 after eello5"
6729 c                do iii=1,nres
6730 c                  write (iout,'(i5,3f10.5)')
6731 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6732 c                enddo
6733                   if (energy_dec.and.wcorr5.gt.0.0d0)
6734      1                 write (iout,'(a6,4i5,0pf7.3)')
6735      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6736 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6737 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6738                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6739      &               .or. wturn6.eq.0.0d0))then
6740 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6741                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6742                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6743      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6744 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6745 cd     &            'ecorr6=',ecorr6
6746 cd                write (iout,'(4e15.5)') sred_geom,
6747 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6748 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6749 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6750                 else if (wturn6.gt.0.0d0
6751      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6752 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6753                   eturn6=eturn6+eello_turn6(i,jj,kk)
6754                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6755      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6756 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6757                 endif
6758               ENDIF
6759 1111          continue
6760             endif
6761           enddo ! kk
6762         enddo ! jj
6763       enddo ! i
6764       do i=1,nres
6765         num_cont_hb(i)=num_cont_hb_old(i)
6766       enddo
6767 c                write (iout,*) "gradcorr5 in eello5"
6768 c                do iii=1,nres
6769 c                  write (iout,'(i5,3f10.5)')
6770 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6771 c                enddo
6772       return
6773       end
6774 c------------------------------------------------------------------------------
6775       subroutine add_hb_contact_eello(ii,jj,itask)
6776       implicit real*8 (a-h,o-z)
6777       include "DIMENSIONS"
6778       include "COMMON.IOUNITS"
6779       integer max_cont
6780       integer max_dim
6781       parameter (max_cont=maxconts)
6782       parameter (max_dim=70)
6783       include "COMMON.CONTACTS"
6784 #ifdef MOMENT
6785       include 'COMMON.CONTACTS.MOMENT'
6786 #endif
6787       double precision zapas(max_dim,maxconts,max_fg_procs),
6788      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6789       common /przechowalnia/ zapas
6790       integer i,j,ii,jj,iproc,itask(4),nn
6791 c      write (iout,*) "itask",itask
6792       do i=1,2
6793         iproc=itask(i)
6794         if (iproc.gt.0) then
6795           do j=1,num_cont_hb(ii)
6796             jjc=jcont_hb(j,ii)
6797 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6798             if (jjc.eq.jj) then
6799               ncont_sent(iproc)=ncont_sent(iproc)+1
6800               nn=ncont_sent(iproc)
6801               zapas(1,nn,iproc)=ii
6802               zapas(2,nn,iproc)=jjc
6803               zapas(3,nn,iproc)=d_cont(j,ii)
6804               ind=3
6805               do kk=1,3
6806                 ind=ind+1
6807                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6808               enddo
6809               do kk=1,2
6810                 do ll=1,2
6811                   ind=ind+1
6812                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6813                 enddo
6814               enddo
6815               do jj=1,5
6816                 do kk=1,3
6817                   do ll=1,2
6818                     do mm=1,2
6819                       ind=ind+1
6820                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6821                     enddo
6822                   enddo
6823                 enddo
6824               enddo
6825               exit
6826             endif
6827           enddo
6828         endif
6829       enddo
6830       return
6831       end
6832 c------------------------------------------------------------------------------
6833       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6834       implicit real*8 (a-h,o-z)
6835       include 'DIMENSIONS'
6836       include 'COMMON.IOUNITS'
6837       include 'COMMON.DERIV'
6838       include 'COMMON.INTERACT'
6839       include 'COMMON.CONTACTS'
6840 #ifdef MOMENT
6841       include 'COMMON.CONTACTS.MOMENT'
6842 #endif
6843       double precision gx(3),gx1(3)
6844       logical lprn
6845       lprn=.false.
6846       eij=facont_hb(jj,i)
6847       ekl=facont_hb(kk,k)
6848       ees0pij=ees0p(jj,i)
6849       ees0pkl=ees0p(kk,k)
6850       ees0mij=ees0m(jj,i)
6851       ees0mkl=ees0m(kk,k)
6852       ekont=eij*ekl
6853       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6854 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6855 C Following 4 lines for diagnostics.
6856 cd    ees0pkl=0.0D0
6857 cd    ees0pij=1.0D0
6858 cd    ees0mkl=0.0D0
6859 cd    ees0mij=1.0D0
6860 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6861 c     & 'Contacts ',i,j,
6862 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6863 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6864 c     & 'gradcorr_long'
6865 C Calculate the multi-body contribution to energy.
6866 c      ecorr=ecorr+ekont*ees
6867 C Calculate multi-body contributions to the gradient.
6868       coeffpees0pij=coeffp*ees0pij
6869       coeffmees0mij=coeffm*ees0mij
6870       coeffpees0pkl=coeffp*ees0pkl
6871       coeffmees0mkl=coeffm*ees0mkl
6872       do ll=1,3
6873 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6874         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6875      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6876      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6877         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6878      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6879      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6880 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6881         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6882      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6883      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6884         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6885      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6886      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6887         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6888      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6889      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6890         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6891         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6892         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6893      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6894      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6895         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6896         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6897 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6898       enddo
6899 c      write (iout,*)
6900 cgrad      do m=i+1,j-1
6901 cgrad        do ll=1,3
6902 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6903 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6904 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6905 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6906 cgrad        enddo
6907 cgrad      enddo
6908 cgrad      do m=k+1,l-1
6909 cgrad        do ll=1,3
6910 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6911 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6912 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6913 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6914 cgrad        enddo
6915 cgrad      enddo
6916 c      write (iout,*) "ehbcorr",ekont*ees
6917       ehbcorr=ekont*ees
6918       return
6919       end
6920 #ifdef MOMENT
6921 C---------------------------------------------------------------------------
6922       subroutine dipole(i,j,jj)
6923       implicit real*8 (a-h,o-z)
6924       include 'DIMENSIONS'
6925       include 'COMMON.IOUNITS'
6926       include 'COMMON.CHAIN'
6927       include 'COMMON.FFIELD'
6928       include 'COMMON.DERIV'
6929       include 'COMMON.INTERACT'
6930       include 'COMMON.CONTACTS'
6931 #ifdef MOMENT
6932       include 'COMMON.CONTACTS.MOMENT'
6933 #endif
6934       include 'COMMON.TORSION'
6935       include 'COMMON.VAR'
6936       include 'COMMON.GEO'
6937       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6938      &  auxmat(2,2)
6939       iti1 = itortyp(itype(i+1))
6940       if (j.lt.nres-1) then
6941         itj1 = itortyp(itype(j+1))
6942       else
6943         itj1=ntortyp+1
6944       endif
6945       do iii=1,2
6946         dipi(iii,1)=Ub2(iii,i)
6947         dipderi(iii)=Ub2der(iii,i)
6948         dipi(iii,2)=b1(iii,iti1)
6949         dipj(iii,1)=Ub2(iii,j)
6950         dipderj(iii)=Ub2der(iii,j)
6951         dipj(iii,2)=b1(iii,itj1)
6952       enddo
6953       kkk=0
6954       do iii=1,2
6955         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6956         do jjj=1,2
6957           kkk=kkk+1
6958           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6959         enddo
6960       enddo
6961       do kkk=1,5
6962         do lll=1,3
6963           mmm=0
6964           do iii=1,2
6965             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6966      &        auxvec(1))
6967             do jjj=1,2
6968               mmm=mmm+1
6969               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6970             enddo
6971           enddo
6972         enddo
6973       enddo
6974       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6975       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6976       do iii=1,2
6977         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6978       enddo
6979       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6980       do iii=1,2
6981         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6982       enddo
6983       return
6984       end
6985 #endif
6986 C---------------------------------------------------------------------------
6987       subroutine calc_eello(i,j,k,l,jj,kk)
6988 C
6989 C This subroutine computes matrices and vectors needed to calculate
6990 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6991 C
6992       implicit real*8 (a-h,o-z)
6993       include 'DIMENSIONS'
6994       include 'COMMON.IOUNITS'
6995       include 'COMMON.CHAIN'
6996       include 'COMMON.DERIV'
6997       include 'COMMON.INTERACT'
6998       include 'COMMON.CONTACTS'
6999 #ifdef MOMENT
7000       include 'COMMON.CONTACTS.MOMENT'
7001 #endif
7002       include 'COMMON.TORSION'
7003       include 'COMMON.VAR'
7004       include 'COMMON.GEO'
7005       include 'COMMON.FFIELD'
7006       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7007      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7008       logical lprn
7009       common /kutas/ lprn
7010 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7011 cd     & ' jj=',jj,' kk=',kk
7012 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7013 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7014 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7015       do iii=1,2
7016         do jjj=1,2
7017           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7018           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7019         enddo
7020       enddo
7021       call transpose2(aa1(1,1),aa1t(1,1))
7022       call transpose2(aa2(1,1),aa2t(1,1))
7023       do kkk=1,5
7024         do lll=1,3
7025           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7026      &      aa1tder(1,1,lll,kkk))
7027           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7028      &      aa2tder(1,1,lll,kkk))
7029         enddo
7030       enddo
7031       if (l.eq.j+1) then
7032 C parallel orientation of the two CA-CA-CA frames.
7033         if (i.gt.1) then
7034           iti=itortyp(itype(i))
7035         else
7036           iti=ntortyp+1
7037         endif
7038         itk1=itortyp(itype(k+1))
7039         itj=itortyp(itype(j))
7040         if (l.lt.nres-1) then
7041           itl1=itortyp(itype(l+1))
7042         else
7043           itl1=ntortyp+1
7044         endif
7045 C A1 kernel(j+1) A2T
7046 cd        do iii=1,2
7047 cd          write (iout,'(3f10.5,5x,3f10.5)')
7048 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7049 cd        enddo
7050         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7051      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7052      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7053 C Following matrices are needed only for 6-th order cumulants
7054         IF (wcorr6.gt.0.0d0) THEN
7055         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7056      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7057      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7058         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7059      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7060      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7061      &   ADtEAderx(1,1,1,1,1,1))
7062         lprn=.false.
7063         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7064      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7065      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7066      &   ADtEA1derx(1,1,1,1,1,1))
7067         ENDIF
7068 C End 6-th order cumulants
7069 cd        lprn=.false.
7070 cd        if (lprn) then
7071 cd        write (2,*) 'In calc_eello6'
7072 cd        do iii=1,2
7073 cd          write (2,*) 'iii=',iii
7074 cd          do kkk=1,5
7075 cd            write (2,*) 'kkk=',kkk
7076 cd            do jjj=1,2
7077 cd              write (2,'(3(2f10.5),5x)')
7078 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7079 cd            enddo
7080 cd          enddo
7081 cd        enddo
7082 cd        endif
7083         call transpose2(EUgder(1,1,k),auxmat(1,1))
7084         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7085         call transpose2(EUg(1,1,k),auxmat(1,1))
7086         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7087         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7088         do iii=1,2
7089           do kkk=1,5
7090             do lll=1,3
7091               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7092      &          EAEAderx(1,1,lll,kkk,iii,1))
7093             enddo
7094           enddo
7095         enddo
7096 C A1T kernel(i+1) A2
7097         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7098      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7099      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7100 C Following matrices are needed only for 6-th order cumulants
7101         IF (wcorr6.gt.0.0d0) THEN
7102         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7103      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7104      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7105         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7106      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7107      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7108      &   ADtEAderx(1,1,1,1,1,2))
7109         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7110      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7111      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7112      &   ADtEA1derx(1,1,1,1,1,2))
7113         ENDIF
7114 C End 6-th order cumulants
7115         call transpose2(EUgder(1,1,l),auxmat(1,1))
7116         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7117         call transpose2(EUg(1,1,l),auxmat(1,1))
7118         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7119         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7120         do iii=1,2
7121           do kkk=1,5
7122             do lll=1,3
7123               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7124      &          EAEAderx(1,1,lll,kkk,iii,2))
7125             enddo
7126           enddo
7127         enddo
7128 C AEAb1 and AEAb2
7129 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7130 C They are needed only when the fifth- or the sixth-order cumulants are
7131 C indluded.
7132         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7133         call transpose2(AEA(1,1,1),auxmat(1,1))
7134         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7135         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7136         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7137         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7138         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7139         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7140         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7141         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7142         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7143         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7144         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7145         call transpose2(AEA(1,1,2),auxmat(1,1))
7146         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7147         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7148         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7149         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7150         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7151         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7152         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7153         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7154         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7155         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7156         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7157 C Calculate the Cartesian derivatives of the vectors.
7158         do iii=1,2
7159           do kkk=1,5
7160             do lll=1,3
7161               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7162               call matvec2(auxmat(1,1),b1(1,iti),
7163      &          AEAb1derx(1,lll,kkk,iii,1,1))
7164               call matvec2(auxmat(1,1),Ub2(1,i),
7165      &          AEAb2derx(1,lll,kkk,iii,1,1))
7166               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7167      &          AEAb1derx(1,lll,kkk,iii,2,1))
7168               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7169      &          AEAb2derx(1,lll,kkk,iii,2,1))
7170               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7171               call matvec2(auxmat(1,1),b1(1,itj),
7172      &          AEAb1derx(1,lll,kkk,iii,1,2))
7173               call matvec2(auxmat(1,1),Ub2(1,j),
7174      &          AEAb2derx(1,lll,kkk,iii,1,2))
7175               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7176      &          AEAb1derx(1,lll,kkk,iii,2,2))
7177               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7178      &          AEAb2derx(1,lll,kkk,iii,2,2))
7179             enddo
7180           enddo
7181         enddo
7182         ENDIF
7183 C End vectors
7184       else
7185 C Antiparallel orientation of the two CA-CA-CA frames.
7186         if (i.gt.1) then
7187           iti=itortyp(itype(i))
7188         else
7189           iti=ntortyp+1
7190         endif
7191         itk1=itortyp(itype(k+1))
7192         itl=itortyp(itype(l))
7193         itj=itortyp(itype(j))
7194         if (j.lt.nres-1) then
7195           itj1=itortyp(itype(j+1))
7196         else
7197           itj1=ntortyp+1
7198         endif
7199 C A2 kernel(j-1)T A1T
7200         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7201      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7202      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7203 C Following matrices are needed only for 6-th order cumulants
7204         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7205      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7206         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7207      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7208      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7209         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7210      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7211      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7212      &   ADtEAderx(1,1,1,1,1,1))
7213         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7214      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7215      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7216      &   ADtEA1derx(1,1,1,1,1,1))
7217         ENDIF
7218 C End 6-th order cumulants
7219         call transpose2(EUgder(1,1,k),auxmat(1,1))
7220         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7221         call transpose2(EUg(1,1,k),auxmat(1,1))
7222         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7223         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7224         do iii=1,2
7225           do kkk=1,5
7226             do lll=1,3
7227               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7228      &          EAEAderx(1,1,lll,kkk,iii,1))
7229             enddo
7230           enddo
7231         enddo
7232 C A2T kernel(i+1)T A1
7233         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7234      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7235      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7236 C Following matrices are needed only for 6-th order cumulants
7237         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7238      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7239         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7240      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7241      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7242         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7243      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7244      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7245      &   ADtEAderx(1,1,1,1,1,2))
7246         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7247      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7248      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7249      &   ADtEA1derx(1,1,1,1,1,2))
7250         ENDIF
7251 C End 6-th order cumulants
7252         call transpose2(EUgder(1,1,j),auxmat(1,1))
7253         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7254         call transpose2(EUg(1,1,j),auxmat(1,1))
7255         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7256         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7257         do iii=1,2
7258           do kkk=1,5
7259             do lll=1,3
7260               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7261      &          EAEAderx(1,1,lll,kkk,iii,2))
7262             enddo
7263           enddo
7264         enddo
7265 C AEAb1 and AEAb2
7266 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7267 C They are needed only when the fifth- or the sixth-order cumulants are
7268 C indluded.
7269         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7270      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7271         call transpose2(AEA(1,1,1),auxmat(1,1))
7272         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7273         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7274         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7275         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7276         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7277         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7278         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7279         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7280         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7281         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7282         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7283         call transpose2(AEA(1,1,2),auxmat(1,1))
7284         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7285         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7286         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7287         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7288         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7289         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7290         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7291         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7292         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7293         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7294         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7295 C Calculate the Cartesian derivatives of the vectors.
7296         do iii=1,2
7297           do kkk=1,5
7298             do lll=1,3
7299               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7300               call matvec2(auxmat(1,1),b1(1,iti),
7301      &          AEAb1derx(1,lll,kkk,iii,1,1))
7302               call matvec2(auxmat(1,1),Ub2(1,i),
7303      &          AEAb2derx(1,lll,kkk,iii,1,1))
7304               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7305      &          AEAb1derx(1,lll,kkk,iii,2,1))
7306               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7307      &          AEAb2derx(1,lll,kkk,iii,2,1))
7308               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7309               call matvec2(auxmat(1,1),b1(1,itl),
7310      &          AEAb1derx(1,lll,kkk,iii,1,2))
7311               call matvec2(auxmat(1,1),Ub2(1,l),
7312      &          AEAb2derx(1,lll,kkk,iii,1,2))
7313               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7314      &          AEAb1derx(1,lll,kkk,iii,2,2))
7315               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7316      &          AEAb2derx(1,lll,kkk,iii,2,2))
7317             enddo
7318           enddo
7319         enddo
7320         ENDIF
7321 C End vectors
7322       endif
7323       return
7324       end
7325 C---------------------------------------------------------------------------
7326       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7327      &  KK,KKderg,AKA,AKAderg,AKAderx)
7328       implicit none
7329       integer nderg
7330       logical transp
7331       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7332      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7333      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7334       integer iii,kkk,lll
7335       integer jjj,mmm
7336       logical lprn
7337       common /kutas/ lprn
7338       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7339       do iii=1,nderg
7340         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7341      &    AKAderg(1,1,iii))
7342       enddo
7343 cd      if (lprn) write (2,*) 'In kernel'
7344       do kkk=1,5
7345 cd        if (lprn) write (2,*) 'kkk=',kkk
7346         do lll=1,3
7347           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7348      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7349 cd          if (lprn) then
7350 cd            write (2,*) 'lll=',lll
7351 cd            write (2,*) 'iii=1'
7352 cd            do jjj=1,2
7353 cd              write (2,'(3(2f10.5),5x)')
7354 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7355 cd            enddo
7356 cd          endif
7357           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7358      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7359 cd          if (lprn) then
7360 cd            write (2,*) 'lll=',lll
7361 cd            write (2,*) 'iii=2'
7362 cd            do jjj=1,2
7363 cd              write (2,'(3(2f10.5),5x)')
7364 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7365 cd            enddo
7366 cd          endif
7367         enddo
7368       enddo
7369       return
7370       end
7371 C---------------------------------------------------------------------------
7372       double precision function eello4(i,j,k,l,jj,kk)
7373       implicit real*8 (a-h,o-z)
7374       include 'DIMENSIONS'
7375       include 'COMMON.IOUNITS'
7376       include 'COMMON.CHAIN'
7377       include 'COMMON.DERIV'
7378       include 'COMMON.INTERACT'
7379       include 'COMMON.CONTACTS'
7380 #ifdef MOMENT
7381       include 'COMMON.CONTACTS.MOMENT'
7382 #endif
7383       include 'COMMON.TORSION'
7384       include 'COMMON.VAR'
7385       include 'COMMON.GEO'
7386       double precision pizda(2,2),ggg1(3),ggg2(3)
7387 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7388 cd        eello4=0.0d0
7389 cd        return
7390 cd      endif
7391 cd      print *,'eello4:',i,j,k,l,jj,kk
7392 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7393 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7394 cold      eij=facont_hb(jj,i)
7395 cold      ekl=facont_hb(kk,k)
7396 cold      ekont=eij*ekl
7397       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7398 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7399       gcorr_loc(k-1)=gcorr_loc(k-1)
7400      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7401       if (l.eq.j+1) then
7402         gcorr_loc(l-1)=gcorr_loc(l-1)
7403      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7404       else
7405         gcorr_loc(j-1)=gcorr_loc(j-1)
7406      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7407       endif
7408       do iii=1,2
7409         do kkk=1,5
7410           do lll=1,3
7411             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7412      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7413 cd            derx(lll,kkk,iii)=0.0d0
7414           enddo
7415         enddo
7416       enddo
7417 cd      gcorr_loc(l-1)=0.0d0
7418 cd      gcorr_loc(j-1)=0.0d0
7419 cd      gcorr_loc(k-1)=0.0d0
7420 cd      eel4=1.0d0
7421 cd      write (iout,*)'Contacts have occurred for peptide groups',
7422 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7423 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7424       if (j.lt.nres-1) then
7425         j1=j+1
7426         j2=j-1
7427       else
7428         j1=j-1
7429         j2=j-2
7430       endif
7431       if (l.lt.nres-1) then
7432         l1=l+1
7433         l2=l-1
7434       else
7435         l1=l-1
7436         l2=l-2
7437       endif
7438       do ll=1,3
7439 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7440 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7441         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7442         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7443 cgrad        ghalf=0.5d0*ggg1(ll)
7444         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7445         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7446         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7447         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7448         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7449         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7450 cgrad        ghalf=0.5d0*ggg2(ll)
7451         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7452         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7453         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7454         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7455         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7456         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7457       enddo
7458 cgrad      do m=i+1,j-1
7459 cgrad        do ll=1,3
7460 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7461 cgrad        enddo
7462 cgrad      enddo
7463 cgrad      do m=k+1,l-1
7464 cgrad        do ll=1,3
7465 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7466 cgrad        enddo
7467 cgrad      enddo
7468 cgrad      do m=i+2,j2
7469 cgrad        do ll=1,3
7470 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7471 cgrad        enddo
7472 cgrad      enddo
7473 cgrad      do m=k+2,l2
7474 cgrad        do ll=1,3
7475 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7476 cgrad        enddo
7477 cgrad      enddo
7478 cd      do iii=1,nres-3
7479 cd        write (2,*) iii,gcorr_loc(iii)
7480 cd      enddo
7481       eello4=ekont*eel4
7482 cd      write (2,*) 'ekont',ekont
7483 cd      write (iout,*) 'eello4',ekont*eel4
7484       return
7485       end
7486 C---------------------------------------------------------------------------
7487       double precision function eello5(i,j,k,l,jj,kk)
7488       implicit real*8 (a-h,o-z)
7489       include 'DIMENSIONS'
7490       include 'COMMON.IOUNITS'
7491       include 'COMMON.CHAIN'
7492       include 'COMMON.DERIV'
7493       include 'COMMON.INTERACT'
7494       include 'COMMON.CONTACTS'
7495 #ifdef MOMENT
7496       include 'COMMON.CONTACTS.MOMENT'
7497 #endif
7498       include 'COMMON.TORSION'
7499       include 'COMMON.VAR'
7500       include 'COMMON.GEO'
7501       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7502       double precision ggg1(3),ggg2(3)
7503 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7504 C                                                                              C
7505 C                            Parallel chains                                   C
7506 C                                                                              C
7507 C          o             o                   o             o                   C
7508 C         /l\           / \             \   / \           / \   /              C
7509 C        /   \         /   \             \ /   \         /   \ /               C
7510 C       j| o |l1       | o |              o| o |         | o |o                C
7511 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7512 C      \i/   \         /   \ /             /   \         /   \                 C
7513 C       o    k1             o                                                  C
7514 C         (I)          (II)                (III)          (IV)                 C
7515 C                                                                              C
7516 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7517 C                                                                              C
7518 C                            Antiparallel chains                               C
7519 C                                                                              C
7520 C          o             o                   o             o                   C
7521 C         /j\           / \             \   / \           / \   /              C
7522 C        /   \         /   \             \ /   \         /   \ /               C
7523 C      j1| o |l        | o |              o| o |         | o |o                C
7524 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7525 C      \i/   \         /   \ /             /   \         /   \                 C
7526 C       o     k1            o                                                  C
7527 C         (I)          (II)                (III)          (IV)                 C
7528 C                                                                              C
7529 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7530 C                                                                              C
7531 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7532 C                                                                              C
7533 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7534 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7535 cd        eello5=0.0d0
7536 cd        return
7537 cd      endif
7538 cd      write (iout,*)
7539 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7540 cd     &   ' and',k,l
7541       itk=itortyp(itype(k))
7542       itl=itortyp(itype(l))
7543       itj=itortyp(itype(j))
7544       eello5_1=0.0d0
7545       eello5_2=0.0d0
7546       eello5_3=0.0d0
7547       eello5_4=0.0d0
7548 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7549 cd     &   eel5_3_num,eel5_4_num)
7550       do iii=1,2
7551         do kkk=1,5
7552           do lll=1,3
7553             derx(lll,kkk,iii)=0.0d0
7554           enddo
7555         enddo
7556       enddo
7557 cd      eij=facont_hb(jj,i)
7558 cd      ekl=facont_hb(kk,k)
7559 cd      ekont=eij*ekl
7560 cd      write (iout,*)'Contacts have occurred for peptide groups',
7561 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7562 cd      goto 1111
7563 C Contribution from the graph I.
7564 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7565 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7566       call transpose2(EUg(1,1,k),auxmat(1,1))
7567       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7568       vv(1)=pizda(1,1)-pizda(2,2)
7569       vv(2)=pizda(1,2)+pizda(2,1)
7570       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7571      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7572 C Explicit gradient in virtual-dihedral angles.
7573       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7574      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7575      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7576       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7577       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7578       vv(1)=pizda(1,1)-pizda(2,2)
7579       vv(2)=pizda(1,2)+pizda(2,1)
7580       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7581      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7582      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7583       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7584       vv(1)=pizda(1,1)-pizda(2,2)
7585       vv(2)=pizda(1,2)+pizda(2,1)
7586       if (l.eq.j+1) then
7587         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7588      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7589      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7590       else
7591         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7592      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7593      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7594       endif
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,1),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,1),Ub2(1,k))
7605      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7606           enddo
7607         enddo
7608       enddo
7609 c      goto 1112
7610 c1111  continue
7611 C Contribution from graph II
7612       call transpose2(EE(1,1,itk),auxmat(1,1))
7613       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7614       vv(1)=pizda(1,1)+pizda(2,2)
7615       vv(2)=pizda(2,1)-pizda(1,2)
7616       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7617      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7618 C Explicit gradient in virtual-dihedral angles.
7619       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7620      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7621       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7622       vv(1)=pizda(1,1)+pizda(2,2)
7623       vv(2)=pizda(2,1)-pizda(1,2)
7624       if (l.eq.j+1) then
7625         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7626      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7627      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7628       else
7629         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7630      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7631      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7632       endif
7633 C Cartesian gradient
7634       do iii=1,2
7635         do kkk=1,5
7636           do lll=1,3
7637             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7638      &        pizda(1,1))
7639             vv(1)=pizda(1,1)+pizda(2,2)
7640             vv(2)=pizda(2,1)-pizda(1,2)
7641             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7642      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7643      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7644           enddo
7645         enddo
7646       enddo
7647 cd      goto 1112
7648 cd1111  continue
7649       if (l.eq.j+1) then
7650 cd        goto 1110
7651 C Parallel orientation
7652 C Contribution from graph III
7653         call transpose2(EUg(1,1,l),auxmat(1,1))
7654         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7655         vv(1)=pizda(1,1)-pizda(2,2)
7656         vv(2)=pizda(1,2)+pizda(2,1)
7657         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7658      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7659 C Explicit gradient in virtual-dihedral angles.
7660         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7661      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7662      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7663         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7664         vv(1)=pizda(1,1)-pizda(2,2)
7665         vv(2)=pizda(1,2)+pizda(2,1)
7666         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7667      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7668      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7669         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7670         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7671         vv(1)=pizda(1,1)-pizda(2,2)
7672         vv(2)=pizda(1,2)+pizda(2,1)
7673         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7674      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7675      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7676 C Cartesian gradient
7677         do iii=1,2
7678           do kkk=1,5
7679             do lll=1,3
7680               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7681      &          pizda(1,1))
7682               vv(1)=pizda(1,1)-pizda(2,2)
7683               vv(2)=pizda(1,2)+pizda(2,1)
7684               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7685      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7686      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7687             enddo
7688           enddo
7689         enddo
7690 cd        goto 1112
7691 C Contribution from graph IV
7692 cd1110    continue
7693         call transpose2(EE(1,1,itl),auxmat(1,1))
7694         call matmat2(auxmat(1,1),AEA(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         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7698      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7699 C Explicit gradient in virtual-dihedral angles.
7700         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7701      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7702         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7703         vv(1)=pizda(1,1)+pizda(2,2)
7704         vv(2)=pizda(2,1)-pizda(1,2)
7705         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7706      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7707      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7708 C Cartesian gradient
7709         do iii=1,2
7710           do kkk=1,5
7711             do lll=1,3
7712               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7713      &          pizda(1,1))
7714               vv(1)=pizda(1,1)+pizda(2,2)
7715               vv(2)=pizda(2,1)-pizda(1,2)
7716               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7717      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7718      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7719             enddo
7720           enddo
7721         enddo
7722       else
7723 C Antiparallel orientation
7724 C Contribution from graph III
7725 c        goto 1110
7726         call transpose2(EUg(1,1,j),auxmat(1,1))
7727         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7728         vv(1)=pizda(1,1)-pizda(2,2)
7729         vv(2)=pizda(1,2)+pizda(2,1)
7730         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7731      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7732 C Explicit gradient in virtual-dihedral angles.
7733         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7734      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7735      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7736         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7737         vv(1)=pizda(1,1)-pizda(2,2)
7738         vv(2)=pizda(1,2)+pizda(2,1)
7739         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7740      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7741      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7742         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7743         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7744         vv(1)=pizda(1,1)-pizda(2,2)
7745         vv(2)=pizda(1,2)+pizda(2,1)
7746         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7747      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7748      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7749 C Cartesian gradient
7750         do iii=1,2
7751           do kkk=1,5
7752             do lll=1,3
7753               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7754      &          pizda(1,1))
7755               vv(1)=pizda(1,1)-pizda(2,2)
7756               vv(2)=pizda(1,2)+pizda(2,1)
7757               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7758      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7759      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7760             enddo
7761           enddo
7762         enddo
7763 cd        goto 1112
7764 C Contribution from graph IV
7765 1110    continue
7766         call transpose2(EE(1,1,itj),auxmat(1,1))
7767         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7768         vv(1)=pizda(1,1)+pizda(2,2)
7769         vv(2)=pizda(2,1)-pizda(1,2)
7770         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7771      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7772 C Explicit gradient in virtual-dihedral angles.
7773         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7774      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7775         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7776         vv(1)=pizda(1,1)+pizda(2,2)
7777         vv(2)=pizda(2,1)-pizda(1,2)
7778         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7779      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7780      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7781 C Cartesian gradient
7782         do iii=1,2
7783           do kkk=1,5
7784             do lll=1,3
7785               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7786      &          pizda(1,1))
7787               vv(1)=pizda(1,1)+pizda(2,2)
7788               vv(2)=pizda(2,1)-pizda(1,2)
7789               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7790      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7791      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7792             enddo
7793           enddo
7794         enddo
7795       endif
7796 1112  continue
7797       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7798 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7799 cd        write (2,*) 'ijkl',i,j,k,l
7800 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7801 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7802 cd      endif
7803 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7804 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7805 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7806 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7807       if (j.lt.nres-1) then
7808         j1=j+1
7809         j2=j-1
7810       else
7811         j1=j-1
7812         j2=j-2
7813       endif
7814       if (l.lt.nres-1) then
7815         l1=l+1
7816         l2=l-1
7817       else
7818         l1=l-1
7819         l2=l-2
7820       endif
7821 cd      eij=1.0d0
7822 cd      ekl=1.0d0
7823 cd      ekont=1.0d0
7824 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7825 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7826 C        summed up outside the subrouine as for the other subroutines
7827 C        handling long-range interactions. The old code is commented out
7828 C        with "cgrad" to keep track of changes.
7829       do ll=1,3
7830 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7831 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7832         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7833         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7834 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7835 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7836 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7837 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7838 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7839 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7840 c     &   gradcorr5ij,
7841 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7842 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7843 cgrad        ghalf=0.5d0*ggg1(ll)
7844 cd        ghalf=0.0d0
7845         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7846         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7847         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7848         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7849         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7850         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7851 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7852 cgrad        ghalf=0.5d0*ggg2(ll)
7853 cd        ghalf=0.0d0
7854         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7855         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7856         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7857         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7858         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7859         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7860       enddo
7861 cd      goto 1112
7862 cgrad      do m=i+1,j-1
7863 cgrad        do ll=1,3
7864 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7865 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7866 cgrad        enddo
7867 cgrad      enddo
7868 cgrad      do m=k+1,l-1
7869 cgrad        do ll=1,3
7870 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7871 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7872 cgrad        enddo
7873 cgrad      enddo
7874 c1112  continue
7875 cgrad      do m=i+2,j2
7876 cgrad        do ll=1,3
7877 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7878 cgrad        enddo
7879 cgrad      enddo
7880 cgrad      do m=k+2,l2
7881 cgrad        do ll=1,3
7882 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7883 cgrad        enddo
7884 cgrad      enddo
7885 cd      do iii=1,nres-3
7886 cd        write (2,*) iii,g_corr5_loc(iii)
7887 cd      enddo
7888       eello5=ekont*eel5
7889 cd      write (2,*) 'ekont',ekont
7890 cd      write (iout,*) 'eello5',ekont*eel5
7891       return
7892       end
7893 c--------------------------------------------------------------------------
7894       double precision function eello6(i,j,k,l,jj,kk)
7895       implicit real*8 (a-h,o-z)
7896       include 'DIMENSIONS'
7897       include 'COMMON.IOUNITS'
7898       include 'COMMON.CHAIN'
7899       include 'COMMON.DERIV'
7900       include 'COMMON.INTERACT'
7901       include 'COMMON.CONTACTS'
7902 #ifdef MOMENT
7903       include 'COMMON.CONTACTS.MOMENT'
7904 #endif
7905       include 'COMMON.TORSION'
7906       include 'COMMON.VAR'
7907       include 'COMMON.GEO'
7908       include 'COMMON.FFIELD'
7909       double precision ggg1(3),ggg2(3)
7910 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7911 cd        eello6=0.0d0
7912 cd        return
7913 cd      endif
7914 cd      write (iout,*)
7915 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7916 cd     &   ' and',k,l
7917       eello6_1=0.0d0
7918       eello6_2=0.0d0
7919       eello6_3=0.0d0
7920       eello6_4=0.0d0
7921       eello6_5=0.0d0
7922       eello6_6=0.0d0
7923 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7924 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7925       do iii=1,2
7926         do kkk=1,5
7927           do lll=1,3
7928             derx(lll,kkk,iii)=0.0d0
7929           enddo
7930         enddo
7931       enddo
7932 cd      eij=facont_hb(jj,i)
7933 cd      ekl=facont_hb(kk,k)
7934 cd      ekont=eij*ekl
7935 cd      eij=1.0d0
7936 cd      ekl=1.0d0
7937 cd      ekont=1.0d0
7938       if (l.eq.j+1) then
7939         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7940         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7941         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7942         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7943         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7944         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7945       else
7946         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7947         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7948         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7949         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7950         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7951           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7952         else
7953           eello6_5=0.0d0
7954         endif
7955         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7956       endif
7957 C If turn contributions are considered, they will be handled separately.
7958       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7959 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7960 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7961 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7962 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7963 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7964 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7965 cd      goto 1112
7966       if (j.lt.nres-1) then
7967         j1=j+1
7968         j2=j-1
7969       else
7970         j1=j-1
7971         j2=j-2
7972       endif
7973       if (l.lt.nres-1) then
7974         l1=l+1
7975         l2=l-1
7976       else
7977         l1=l-1
7978         l2=l-2
7979       endif
7980       do ll=1,3
7981 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7982 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7983 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7984 cgrad        ghalf=0.5d0*ggg1(ll)
7985 cd        ghalf=0.0d0
7986         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7987         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7988         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7989         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7990         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7991         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7992         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7993         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7994 cgrad        ghalf=0.5d0*ggg2(ll)
7995 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7996 cd        ghalf=0.0d0
7997         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7998         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7999         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8000         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8001         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8002         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8003       enddo
8004 cd      goto 1112
8005 cgrad      do m=i+1,j-1
8006 cgrad        do ll=1,3
8007 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8008 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8009 cgrad        enddo
8010 cgrad      enddo
8011 cgrad      do m=k+1,l-1
8012 cgrad        do ll=1,3
8013 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8014 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8015 cgrad        enddo
8016 cgrad      enddo
8017 cgrad1112  continue
8018 cgrad      do m=i+2,j2
8019 cgrad        do ll=1,3
8020 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8021 cgrad        enddo
8022 cgrad      enddo
8023 cgrad      do m=k+2,l2
8024 cgrad        do ll=1,3
8025 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8026 cgrad        enddo
8027 cgrad      enddo
8028 cd      do iii=1,nres-3
8029 cd        write (2,*) iii,g_corr6_loc(iii)
8030 cd      enddo
8031       eello6=ekont*eel6
8032 cd      write (2,*) 'ekont',ekont
8033 cd      write (iout,*) 'eello6',ekont*eel6
8034       return
8035       end
8036 c--------------------------------------------------------------------------
8037       double precision function eello6_graph1(i,j,k,l,imat,swap)
8038       implicit real*8 (a-h,o-z)
8039       include 'DIMENSIONS'
8040       include 'COMMON.IOUNITS'
8041       include 'COMMON.CHAIN'
8042       include 'COMMON.DERIV'
8043       include 'COMMON.INTERACT'
8044       include 'COMMON.CONTACTS'
8045 #ifdef MOMENT
8046       include 'COMMON.CONTACTS.MOMENT'
8047 #endif
8048       include 'COMMON.TORSION'
8049       include 'COMMON.VAR'
8050       include 'COMMON.GEO'
8051       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8052       logical swap
8053       logical lprn
8054       common /kutas/ lprn
8055 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8056 C                                                                              C
8057 C      Parallel       Antiparallel                                             C
8058 C                                                                              C
8059 C          o             o                                                     C
8060 C         /l\           /j\                                                    C
8061 C        /   \         /   \                                                   C
8062 C       /| o |         | o |\                                                  C
8063 C     \ j|/k\|  /   \  |/k\|l /                                                C
8064 C      \ /   \ /     \ /   \ /                                                 C
8065 C       o     o       o     o                                                  C
8066 C       i             i                                                        C
8067 C                                                                              C
8068 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8069       itk=itortyp(itype(k))
8070       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8071       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8072       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8073       call transpose2(EUgC(1,1,k),auxmat(1,1))
8074       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8075       vv1(1)=pizda1(1,1)-pizda1(2,2)
8076       vv1(2)=pizda1(1,2)+pizda1(2,1)
8077       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8078       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8079       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8080       s5=scalar2(vv(1),Dtobr2(1,i))
8081 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8082       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8083       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8084      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8085      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8086      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8087      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8088      & +scalar2(vv(1),Dtobr2der(1,i)))
8089       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8090       vv1(1)=pizda1(1,1)-pizda1(2,2)
8091       vv1(2)=pizda1(1,2)+pizda1(2,1)
8092       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8093       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8094       if (l.eq.j+1) then
8095         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8096      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8097      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8098      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8099      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8100       else
8101         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8102      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8103      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8104      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8105      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8106       endif
8107       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8108       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8109       vv1(1)=pizda1(1,1)-pizda1(2,2)
8110       vv1(2)=pizda1(1,2)+pizda1(2,1)
8111       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8112      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8113      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8114      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8115       do iii=1,2
8116         if (swap) then
8117           ind=3-iii
8118         else
8119           ind=iii
8120         endif
8121         do kkk=1,5
8122           do lll=1,3
8123             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8124             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8125             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8126             call transpose2(EUgC(1,1,k),auxmat(1,1))
8127             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8128      &        pizda1(1,1))
8129             vv1(1)=pizda1(1,1)-pizda1(2,2)
8130             vv1(2)=pizda1(1,2)+pizda1(2,1)
8131             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8132             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8133      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8134             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8135      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8136             s5=scalar2(vv(1),Dtobr2(1,i))
8137             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8138           enddo
8139         enddo
8140       enddo
8141       return
8142       end
8143 c----------------------------------------------------------------------------
8144       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8145       implicit real*8 (a-h,o-z)
8146       include 'DIMENSIONS'
8147       include 'COMMON.IOUNITS'
8148       include 'COMMON.CHAIN'
8149       include 'COMMON.DERIV'
8150       include 'COMMON.INTERACT'
8151       include 'COMMON.CONTACTS'
8152 #ifdef MOMENT
8153       include 'COMMON.CONTACTS.MOMENT'
8154 #endif
8155       include 'COMMON.TORSION'
8156       include 'COMMON.VAR'
8157       include 'COMMON.GEO'
8158       logical swap
8159       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8160      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8161       logical lprn
8162       common /kutas/ lprn
8163 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8164 C                                                                              C
8165 C      Parallel       Antiparallel                                             C
8166 C                                                                              C
8167 C          o             o                                                     C
8168 C     \   /l\           /j\   /                                                C
8169 C      \ /   \         /   \ /                                                 C
8170 C       o| o |         | o |o                                                  C
8171 C     \ j|/k\|      \  |/k\|l                                                  C
8172 C      \ /   \       \ /   \                                                   C
8173 C       o             o                                                        C
8174 C       i             i                                                        C
8175 C                                                                              C
8176 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8177 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8178 C AL 7/4/01 s1 would occur in the sixth-order moment,
8179 C           but not in a cluster cumulant
8180 #ifdef MOMENT
8181       s1=dip(1,jj,i)*dip(1,kk,k)
8182 #endif
8183       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8184       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8185       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8186       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8187       call transpose2(EUg(1,1,k),auxmat(1,1))
8188       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8189       vv(1)=pizda(1,1)-pizda(2,2)
8190       vv(2)=pizda(1,2)+pizda(2,1)
8191       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8192 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8193 #ifdef MOMENT
8194       eello6_graph2=-(s1+s2+s3+s4)
8195 #else
8196       eello6_graph2=-(s2+s3+s4)
8197 #endif
8198 c      eello6_graph2=-s3
8199 C Derivatives in gamma(i-1)
8200       if (i.gt.1) then
8201 #ifdef MOMENT
8202         s1=dipderg(1,jj,i)*dip(1,kk,k)
8203 #endif
8204         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8205         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8206         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8207         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8208 #ifdef MOMENT
8209         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8210 #else
8211         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8212 #endif
8213 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8214       endif
8215 C Derivatives in gamma(k-1)
8216 #ifdef MOMENT
8217       s1=dip(1,jj,i)*dipderg(1,kk,k)
8218 #endif
8219       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8220       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8221       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8222       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8223       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8224       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8225       vv(1)=pizda(1,1)-pizda(2,2)
8226       vv(2)=pizda(1,2)+pizda(2,1)
8227       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8228 #ifdef MOMENT
8229       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8230 #else
8231       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8232 #endif
8233 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8234 C Derivatives in gamma(j-1) or gamma(l-1)
8235       if (j.gt.1) then
8236 #ifdef MOMENT
8237         s1=dipderg(3,jj,i)*dip(1,kk,k)
8238 #endif
8239         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8240         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8241         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8242         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8243         vv(1)=pizda(1,1)-pizda(2,2)
8244         vv(2)=pizda(1,2)+pizda(2,1)
8245         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8246 #ifdef MOMENT
8247         if (swap) then
8248           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8249         else
8250           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8251         endif
8252 #endif
8253         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8254 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8255       endif
8256 C Derivatives in gamma(l-1) or gamma(j-1)
8257       if (l.gt.1) then
8258 #ifdef MOMENT
8259         s1=dip(1,jj,i)*dipderg(3,kk,k)
8260 #endif
8261         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8262         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8263         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8264         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8265         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8266         vv(1)=pizda(1,1)-pizda(2,2)
8267         vv(2)=pizda(1,2)+pizda(2,1)
8268         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8269 #ifdef MOMENT
8270         if (swap) then
8271           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8272         else
8273           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8274         endif
8275 #endif
8276         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8277 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8278       endif
8279 C Cartesian derivatives.
8280       if (lprn) then
8281         write (2,*) 'In eello6_graph2'
8282         do iii=1,2
8283           write (2,*) 'iii=',iii
8284           do kkk=1,5
8285             write (2,*) 'kkk=',kkk
8286             do jjj=1,2
8287               write (2,'(3(2f10.5),5x)')
8288      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8289             enddo
8290           enddo
8291         enddo
8292       endif
8293       do iii=1,2
8294         do kkk=1,5
8295           do lll=1,3
8296 #ifdef MOMENT
8297             if (iii.eq.1) then
8298               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8299             else
8300               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8301             endif
8302 #endif
8303             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8304      &        auxvec(1))
8305             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8306             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8307      &        auxvec(1))
8308             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8309             call transpose2(EUg(1,1,k),auxmat(1,1))
8310             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8311      &        pizda(1,1))
8312             vv(1)=pizda(1,1)-pizda(2,2)
8313             vv(2)=pizda(1,2)+pizda(2,1)
8314             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8315 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8316 #ifdef MOMENT
8317             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8318 #else
8319             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8320 #endif
8321             if (swap) then
8322               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8323             else
8324               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8325             endif
8326           enddo
8327         enddo
8328       enddo
8329       return
8330       end
8331 c----------------------------------------------------------------------------
8332       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8333       implicit real*8 (a-h,o-z)
8334       include 'DIMENSIONS'
8335       include 'COMMON.IOUNITS'
8336       include 'COMMON.CHAIN'
8337       include 'COMMON.DERIV'
8338       include 'COMMON.INTERACT'
8339       include 'COMMON.CONTACTS'
8340 #ifdef MOMENT
8341       include 'COMMON.CONTACTS.MOMENT'
8342 #endif
8343       include 'COMMON.TORSION'
8344       include 'COMMON.VAR'
8345       include 'COMMON.GEO'
8346       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8347       logical swap
8348 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8349 C                                                                              C
8350 C      Parallel       Antiparallel                                             C
8351 C                                                                              C
8352 C          o             o                                                     C
8353 C         /l\   /   \   /j\                                                    C
8354 C        /   \ /     \ /   \                                                   C
8355 C       /| o |o       o| o |\                                                  C
8356 C       j|/k\|  /      |/k\|l /                                                C
8357 C        /   \ /       /   \ /                                                 C
8358 C       /     o       /     o                                                  C
8359 C       i             i                                                        C
8360 C                                                                              C
8361 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8362 C
8363 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8364 C           energy moment and not to the cluster cumulant.
8365       iti=itortyp(itype(i))
8366       if (j.lt.nres-1) then
8367         itj1=itortyp(itype(j+1))
8368       else
8369         itj1=ntortyp+1
8370       endif
8371       itk=itortyp(itype(k))
8372       itk1=itortyp(itype(k+1))
8373       if (l.lt.nres-1) then
8374         itl1=itortyp(itype(l+1))
8375       else
8376         itl1=ntortyp+1
8377       endif
8378 #ifdef MOMENT
8379       s1=dip(4,jj,i)*dip(4,kk,k)
8380 #endif
8381       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8382       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8383       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8384       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8385       call transpose2(EE(1,1,itk),auxmat(1,1))
8386       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8387       vv(1)=pizda(1,1)+pizda(2,2)
8388       vv(2)=pizda(2,1)-pizda(1,2)
8389       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8390 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8391 cd     & "sum",-(s2+s3+s4)
8392 #ifdef MOMENT
8393       eello6_graph3=-(s1+s2+s3+s4)
8394 #else
8395       eello6_graph3=-(s2+s3+s4)
8396 #endif
8397 c      eello6_graph3=-s4
8398 C Derivatives in gamma(k-1)
8399       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8400       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8401       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8402       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8403 C Derivatives in gamma(l-1)
8404       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8405       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8406       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8407       vv(1)=pizda(1,1)+pizda(2,2)
8408       vv(2)=pizda(2,1)-pizda(1,2)
8409       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8410       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8411 C Cartesian derivatives.
8412       do iii=1,2
8413         do kkk=1,5
8414           do lll=1,3
8415 #ifdef MOMENT
8416             if (iii.eq.1) then
8417               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8418             else
8419               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8420             endif
8421 #endif
8422             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8423      &        auxvec(1))
8424             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8425             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8426      &        auxvec(1))
8427             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8428             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8429      &        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),Ctobr(1,k))
8433 #ifdef MOMENT
8434             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8435 #else
8436             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8437 #endif
8438             if (swap) then
8439               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8440             else
8441               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8442             endif
8443 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8444           enddo
8445         enddo
8446       enddo
8447       return
8448       end
8449 c----------------------------------------------------------------------------
8450       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8451       implicit real*8 (a-h,o-z)
8452       include 'DIMENSIONS'
8453       include 'COMMON.IOUNITS'
8454       include 'COMMON.CHAIN'
8455       include 'COMMON.DERIV'
8456       include 'COMMON.INTERACT'
8457       include 'COMMON.CONTACTS'
8458 #ifdef MOMENT
8459       include 'COMMON.CONTACTS.MOMENT'
8460 #endif
8461       include 'COMMON.TORSION'
8462       include 'COMMON.VAR'
8463       include 'COMMON.GEO'
8464       include 'COMMON.FFIELD'
8465       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8466      & auxvec1(2),auxmat1(2,2)
8467       logical swap
8468 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8469 C                                                                              C
8470 C      Parallel       Antiparallel                                             C
8471 C                                                                              C
8472 C          o             o                                                     C
8473 C         /l\   /   \   /j\                                                    C
8474 C        /   \ /     \ /   \                                                   C
8475 C       /| o |o       o| o |\                                                  C
8476 C     \ j|/k\|      \  |/k\|l                                                  C
8477 C      \ /   \       \ /   \                                                   C
8478 C       o     \       o     \                                                  C
8479 C       i             i                                                        C
8480 C                                                                              C
8481 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8482 C
8483 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8484 C           energy moment and not to the cluster cumulant.
8485 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8486       iti=itortyp(itype(i))
8487       itj=itortyp(itype(j))
8488       if (j.lt.nres-1) then
8489         itj1=itortyp(itype(j+1))
8490       else
8491         itj1=ntortyp+1
8492       endif
8493       itk=itortyp(itype(k))
8494       if (k.lt.nres-1) then
8495         itk1=itortyp(itype(k+1))
8496       else
8497         itk1=ntortyp+1
8498       endif
8499       itl=itortyp(itype(l))
8500       if (l.lt.nres-1) then
8501         itl1=itortyp(itype(l+1))
8502       else
8503         itl1=ntortyp+1
8504       endif
8505 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8506 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8507 cd     & ' itl',itl,' itl1',itl1
8508 #ifdef MOMENT
8509       if (imat.eq.1) then
8510         s1=dip(3,jj,i)*dip(3,kk,k)
8511       else
8512         s1=dip(2,jj,j)*dip(2,kk,l)
8513       endif
8514 #endif
8515       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8516       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8517       if (j.eq.l+1) then
8518         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8519         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8520       else
8521         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8522         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8523       endif
8524       call transpose2(EUg(1,1,k),auxmat(1,1))
8525       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8526       vv(1)=pizda(1,1)-pizda(2,2)
8527       vv(2)=pizda(2,1)+pizda(1,2)
8528       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8529 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8530 #ifdef MOMENT
8531       eello6_graph4=-(s1+s2+s3+s4)
8532 #else
8533       eello6_graph4=-(s2+s3+s4)
8534 #endif
8535 C Derivatives in gamma(i-1)
8536       if (i.gt.1) then
8537 #ifdef MOMENT
8538         if (imat.eq.1) then
8539           s1=dipderg(2,jj,i)*dip(3,kk,k)
8540         else
8541           s1=dipderg(4,jj,j)*dip(2,kk,l)
8542         endif
8543 #endif
8544         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8545         if (j.eq.l+1) then
8546           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8547           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8548         else
8549           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8550           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8551         endif
8552         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8553         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8554 cd          write (2,*) 'turn6 derivatives'
8555 #ifdef MOMENT
8556           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8557 #else
8558           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8559 #endif
8560         else
8561 #ifdef MOMENT
8562           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8563 #else
8564           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8565 #endif
8566         endif
8567       endif
8568 C Derivatives in gamma(k-1)
8569 #ifdef MOMENT
8570       if (imat.eq.1) then
8571         s1=dip(3,jj,i)*dipderg(2,kk,k)
8572       else
8573         s1=dip(2,jj,j)*dipderg(4,kk,l)
8574       endif
8575 #endif
8576       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8577       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8578       if (j.eq.l+1) then
8579         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8580         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8581       else
8582         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8583         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8584       endif
8585       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8586       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8587       vv(1)=pizda(1,1)-pizda(2,2)
8588       vv(2)=pizda(2,1)+pizda(1,2)
8589       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8590       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8591 #ifdef MOMENT
8592         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8593 #else
8594         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8595 #endif
8596       else
8597 #ifdef MOMENT
8598         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8599 #else
8600         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8601 #endif
8602       endif
8603 C Derivatives in gamma(j-1) or gamma(l-1)
8604       if (l.eq.j+1 .and. l.gt.1) then
8605         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8606         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8607         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8608         vv(1)=pizda(1,1)-pizda(2,2)
8609         vv(2)=pizda(2,1)+pizda(1,2)
8610         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8611         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8612       else if (j.gt.1) then
8613         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8614         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8615         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8616         vv(1)=pizda(1,1)-pizda(2,2)
8617         vv(2)=pizda(2,1)+pizda(1,2)
8618         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8619         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8620           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8621         else
8622           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8623         endif
8624       endif
8625 C Cartesian derivatives.
8626       do iii=1,2
8627         do kkk=1,5
8628           do lll=1,3
8629 #ifdef MOMENT
8630             if (iii.eq.1) then
8631               if (imat.eq.1) then
8632                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8633               else
8634                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8635               endif
8636             else
8637               if (imat.eq.1) then
8638                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8639               else
8640                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8641               endif
8642             endif
8643 #endif
8644             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8645      &        auxvec(1))
8646             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8647             if (j.eq.l+1) then
8648               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8649      &          b1(1,itj1),auxvec(1))
8650               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8651             else
8652               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8653      &          b1(1,itl1),auxvec(1))
8654               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8655             endif
8656             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8657      &        pizda(1,1))
8658             vv(1)=pizda(1,1)-pizda(2,2)
8659             vv(2)=pizda(2,1)+pizda(1,2)
8660             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8661             if (swap) then
8662               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8663 #ifdef MOMENT
8664                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8665      &             -(s1+s2+s4)
8666 #else
8667                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8668      &             -(s2+s4)
8669 #endif
8670                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8671               else
8672 #ifdef MOMENT
8673                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8674 #else
8675                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8676 #endif
8677                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8678               endif
8679             else
8680 #ifdef MOMENT
8681               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8682 #else
8683               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8684 #endif
8685               if (l.eq.j+1) then
8686                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8687               else
8688                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8689               endif
8690             endif
8691           enddo
8692         enddo
8693       enddo
8694       return
8695       end
8696 c----------------------------------------------------------------------------
8697       double precision function eello_turn6(i,jj,kk)
8698       implicit real*8 (a-h,o-z)
8699       include 'DIMENSIONS'
8700       include 'COMMON.IOUNITS'
8701       include 'COMMON.CHAIN'
8702       include 'COMMON.DERIV'
8703       include 'COMMON.INTERACT'
8704       include 'COMMON.CONTACTS'
8705 #ifdef MOMENT
8706       include 'COMMON.CONTACTS.MOMENT'
8707 #endif
8708       include 'COMMON.TORSION'
8709       include 'COMMON.VAR'
8710       include 'COMMON.GEO'
8711       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8712      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8713      &  ggg1(3),ggg2(3)
8714       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8715      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8716 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8717 C           the respective energy moment and not to the cluster cumulant.
8718       s1=0.0d0
8719       s8=0.0d0
8720       s13=0.0d0
8721 c
8722       eello_turn6=0.0d0
8723       j=i+4
8724       k=i+1
8725       l=i+3
8726       iti=itortyp(itype(i))
8727       itk=itortyp(itype(k))
8728       itk1=itortyp(itype(k+1))
8729       itl=itortyp(itype(l))
8730       itj=itortyp(itype(j))
8731 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8732 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8733 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8734 cd        eello6=0.0d0
8735 cd        return
8736 cd      endif
8737 cd      write (iout,*)
8738 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8739 cd     &   ' and',k,l
8740 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8741       do iii=1,2
8742         do kkk=1,5
8743           do lll=1,3
8744             derx_turn(lll,kkk,iii)=0.0d0
8745           enddo
8746         enddo
8747       enddo
8748 cd      eij=1.0d0
8749 cd      ekl=1.0d0
8750 cd      ekont=1.0d0
8751       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8752 cd      eello6_5=0.0d0
8753 cd      write (2,*) 'eello6_5',eello6_5
8754 #ifdef MOMENT
8755       call transpose2(AEA(1,1,1),auxmat(1,1))
8756       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8757       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8758       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8759 #endif
8760       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8761       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8762       s2 = scalar2(b1(1,itk),vtemp1(1))
8763 #ifdef MOMENT
8764       call transpose2(AEA(1,1,2),atemp(1,1))
8765       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8766       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8767       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8768 #endif
8769       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8770       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8771       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8772 #ifdef MOMENT
8773       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8774       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8775       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8776       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8777       ss13 = scalar2(b1(1,itk),vtemp4(1))
8778       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8779 #endif
8780 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8781 c      s1=0.0d0
8782 c      s2=0.0d0
8783 c      s8=0.0d0
8784 c      s12=0.0d0
8785 c      s13=0.0d0
8786       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8787 C Derivatives in gamma(i+2)
8788       s1d =0.0d0
8789       s8d =0.0d0
8790 #ifdef MOMENT
8791       call transpose2(AEA(1,1,1),auxmatd(1,1))
8792       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8793       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8794       call transpose2(AEAderg(1,1,2),atempd(1,1))
8795       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8796       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8797 #endif
8798       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8799       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8800       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8801 c      s1d=0.0d0
8802 c      s2d=0.0d0
8803 c      s8d=0.0d0
8804 c      s12d=0.0d0
8805 c      s13d=0.0d0
8806       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8807 C Derivatives in gamma(i+3)
8808 #ifdef MOMENT
8809       call transpose2(AEA(1,1,1),auxmatd(1,1))
8810       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8811       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8812       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8813 #endif
8814       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8815       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8816       s2d = scalar2(b1(1,itk),vtemp1d(1))
8817 #ifdef MOMENT
8818       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8819       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8820 #endif
8821       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8822 #ifdef MOMENT
8823       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8824       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8825       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8826 #endif
8827 c      s1d=0.0d0
8828 c      s2d=0.0d0
8829 c      s8d=0.0d0
8830 c      s12d=0.0d0
8831 c      s13d=0.0d0
8832 #ifdef MOMENT
8833       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8834      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8835 #else
8836       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8837      &               -0.5d0*ekont*(s2d+s12d)
8838 #endif
8839 C Derivatives in gamma(i+4)
8840       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8841       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8842       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8843 #ifdef MOMENT
8844       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8845       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8846       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8847 #endif
8848 c      s1d=0.0d0
8849 c      s2d=0.0d0
8850 c      s8d=0.0d0
8851 C      s12d=0.0d0
8852 c      s13d=0.0d0
8853 #ifdef MOMENT
8854       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8855 #else
8856       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8857 #endif
8858 C Derivatives in gamma(i+5)
8859 #ifdef MOMENT
8860       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8861       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8862       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8863 #endif
8864       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8865       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8866       s2d = scalar2(b1(1,itk),vtemp1d(1))
8867 #ifdef MOMENT
8868       call transpose2(AEA(1,1,2),atempd(1,1))
8869       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8870       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8871 #endif
8872       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8873       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8874 #ifdef MOMENT
8875       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8876       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8877       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8878 #endif
8879 c      s1d=0.0d0
8880 c      s2d=0.0d0
8881 c      s8d=0.0d0
8882 c      s12d=0.0d0
8883 c      s13d=0.0d0
8884 #ifdef MOMENT
8885       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8886      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8887 #else
8888       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8889      &               -0.5d0*ekont*(s2d+s12d)
8890 #endif
8891 C Cartesian derivatives
8892       do iii=1,2
8893         do kkk=1,5
8894           do lll=1,3
8895 #ifdef MOMENT
8896             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8897             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8898             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8899 #endif
8900             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8901             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8902      &          vtemp1d(1))
8903             s2d = scalar2(b1(1,itk),vtemp1d(1))
8904 #ifdef MOMENT
8905             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8906             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8907             s8d = -(atempd(1,1)+atempd(2,2))*
8908      &           scalar2(cc(1,1,itl),vtemp2(1))
8909 #endif
8910             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8911      &           auxmatd(1,1))
8912             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8913             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8914 c      s1d=0.0d0
8915 c      s2d=0.0d0
8916 c      s8d=0.0d0
8917 c      s12d=0.0d0
8918 c      s13d=0.0d0
8919 #ifdef MOMENT
8920             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8921      &        - 0.5d0*(s1d+s2d)
8922 #else
8923             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8924      &        - 0.5d0*s2d
8925 #endif
8926 #ifdef MOMENT
8927             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8928      &        - 0.5d0*(s8d+s12d)
8929 #else
8930             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8931      &        - 0.5d0*s12d
8932 #endif
8933           enddo
8934         enddo
8935       enddo
8936 #ifdef MOMENT
8937       do kkk=1,5
8938         do lll=1,3
8939           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8940      &      achuj_tempd(1,1))
8941           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8942           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8943           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8944           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8945           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8946      &      vtemp4d(1))
8947           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8948           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8949           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8950         enddo
8951       enddo
8952 #endif
8953 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8954 cd     &  16*eel_turn6_num
8955 cd      goto 1112
8956       if (j.lt.nres-1) then
8957         j1=j+1
8958         j2=j-1
8959       else
8960         j1=j-1
8961         j2=j-2
8962       endif
8963       if (l.lt.nres-1) then
8964         l1=l+1
8965         l2=l-1
8966       else
8967         l1=l-1
8968         l2=l-2
8969       endif
8970       do ll=1,3
8971 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8972 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8973 cgrad        ghalf=0.5d0*ggg1(ll)
8974 cd        ghalf=0.0d0
8975         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8976         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8977         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8978      &    +ekont*derx_turn(ll,2,1)
8979         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8980         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8981      &    +ekont*derx_turn(ll,4,1)
8982         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8983         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8984         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8985 cgrad        ghalf=0.5d0*ggg2(ll)
8986 cd        ghalf=0.0d0
8987         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8988      &    +ekont*derx_turn(ll,2,2)
8989         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8990         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8991      &    +ekont*derx_turn(ll,4,2)
8992         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8993         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8994         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8995       enddo
8996 cd      goto 1112
8997 cgrad      do m=i+1,j-1
8998 cgrad        do ll=1,3
8999 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9000 cgrad        enddo
9001 cgrad      enddo
9002 cgrad      do m=k+1,l-1
9003 cgrad        do ll=1,3
9004 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9005 cgrad        enddo
9006 cgrad      enddo
9007 cgrad1112  continue
9008 cgrad      do m=i+2,j2
9009 cgrad        do ll=1,3
9010 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9011 cgrad        enddo
9012 cgrad      enddo
9013 cgrad      do m=k+2,l2
9014 cgrad        do ll=1,3
9015 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9016 cgrad        enddo
9017 cgrad      enddo
9018 cd      do iii=1,nres-3
9019 cd        write (2,*) iii,g_corr6_loc(iii)
9020 cd      enddo
9021       eello_turn6=ekont*eel_turn6
9022 cd      write (2,*) 'ekont',ekont
9023 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9024       return
9025       end
9026
9027 C-----------------------------------------------------------------------------
9028       double precision function scalar(u,v)
9029 !DIR$ INLINEALWAYS scalar
9030 #ifndef OSF
9031 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9032 #endif
9033       implicit none
9034       double precision u(3),v(3)
9035 cd      double precision sc
9036 cd      integer i
9037 cd      sc=0.0d0
9038 cd      do i=1,3
9039 cd        sc=sc+u(i)*v(i)
9040 cd      enddo
9041 cd      scalar=sc
9042
9043       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9044       return
9045       end
9046 crc-------------------------------------------------
9047       SUBROUTINE MATVEC2(A1,V1,V2)
9048 !DIR$ INLINEALWAYS MATVEC2
9049 #ifndef OSF
9050 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9051 #endif
9052       implicit real*8 (a-h,o-z)
9053       include 'DIMENSIONS'
9054       DIMENSION A1(2,2),V1(2),V2(2)
9055 c      DO 1 I=1,2
9056 c        VI=0.0
9057 c        DO 3 K=1,2
9058 c    3     VI=VI+A1(I,K)*V1(K)
9059 c        Vaux(I)=VI
9060 c    1 CONTINUE
9061
9062       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9063       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9064
9065       v2(1)=vaux1
9066       v2(2)=vaux2
9067       END
9068 C---------------------------------------
9069       SUBROUTINE MATMAT2(A1,A2,A3)
9070 #ifndef OSF
9071 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9072 #endif
9073       implicit real*8 (a-h,o-z)
9074       include 'DIMENSIONS'
9075       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9076 c      DIMENSION AI3(2,2)
9077 c        DO  J=1,2
9078 c          A3IJ=0.0
9079 c          DO K=1,2
9080 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9081 c          enddo
9082 c          A3(I,J)=A3IJ
9083 c       enddo
9084 c      enddo
9085
9086       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9087       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9088       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9089       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9090
9091       A3(1,1)=AI3_11
9092       A3(2,1)=AI3_21
9093       A3(1,2)=AI3_12
9094       A3(2,2)=AI3_22
9095       END
9096
9097 c-------------------------------------------------------------------------
9098       double precision function scalar2(u,v)
9099 !DIR$ INLINEALWAYS scalar2
9100       implicit none
9101       double precision u(2),v(2)
9102       double precision sc
9103       integer i
9104       scalar2=u(1)*v(1)+u(2)*v(2)
9105       return
9106       end
9107
9108 C-----------------------------------------------------------------------------
9109
9110       subroutine transpose2(a,at)
9111 !DIR$ INLINEALWAYS transpose2
9112 #ifndef OSF
9113 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9114 #endif
9115       implicit none
9116       double precision a(2,2),at(2,2)
9117       at(1,1)=a(1,1)
9118       at(1,2)=a(2,1)
9119       at(2,1)=a(1,2)
9120       at(2,2)=a(2,2)
9121       return
9122       end
9123 c--------------------------------------------------------------------------
9124       subroutine transpose(n,a,at)
9125       implicit none
9126       integer n,i,j
9127       double precision a(n,n),at(n,n)
9128       do i=1,n
9129         do j=1,n
9130           at(j,i)=a(i,j)
9131         enddo
9132       enddo
9133       return
9134       end
9135 C---------------------------------------------------------------------------
9136       subroutine prodmat3(a1,a2,kk,transp,prod)
9137 !DIR$ INLINEALWAYS prodmat3
9138 #ifndef OSF
9139 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9140 #endif
9141       implicit none
9142       integer i,j
9143       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9144       logical transp
9145 crc      double precision auxmat(2,2),prod_(2,2)
9146
9147       if (transp) then
9148 crc        call transpose2(kk(1,1),auxmat(1,1))
9149 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9150 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9151
9152            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9153      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9154            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9155      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9156            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9157      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9158            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9159      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9160
9161       else
9162 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9163 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9164
9165            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9166      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9167            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9168      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9169            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9170      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9171            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9172      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9173
9174       endif
9175 c      call transpose2(a2(1,1),a2t(1,1))
9176
9177 crc      print *,transp
9178 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9179 crc      print *,((prod(i,j),i=1,2),j=1,2)
9180
9181       return
9182       end
9183