source/unres/src_CSA_DiL/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=iabs(itype(i))
1093         itypi1=iabs(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=iabs(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=iabs(itype(i))
1270         itypi1=iabs(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=iabs(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=iabs(itype(i))
1387         itypi1=iabs(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=iabs(itype(i))
1523         itypi1=iabs(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=iabs(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=iabs(itype(i))
1682         itypi1=iabs(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=iabs(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=iabs(itype(i))
2005         itypi1=iabs(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=iabs(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=iabs(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=iabs(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. iabs(itype(iii)).eq.1 .and. iabs(itype(jjj
4246      &)).eq.1) then
4247           call ssbond_ene(iii,jjj,eij)
4248           ehpb=ehpb+2*eij
4249 cd          write (iout,*) "eij",eij
4250         else
4251 C Calculate the distance between the two points and its difference from the
4252 C target distance.
4253         dd=dist(ii,jj)
4254         rdis=dd-dhpb(i)
4255 C Get the force constant corresponding to this distance.
4256         waga=forcon(i)
4257 C Calculate the contribution to energy.
4258         ehpb=ehpb+waga*rdis*rdis
4259 C
4260 C Evaluate gradient.
4261 C
4262         fac=waga*rdis/dd
4263 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4264 cd   &   ' waga=',waga,' fac=',fac
4265         do j=1,3
4266           ggg(j)=fac*(c(j,jj)-c(j,ii))
4267         enddo
4268 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4269 C If this is a SC-SC distance, we need to calculate the contributions to the
4270 C Cartesian gradient in the SC vectors (ghpbx).
4271         if (iii.lt.ii) then
4272           do j=1,3
4273             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4274             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4275           enddo
4276         endif
4277 cgrad        do j=iii,jjj-1
4278 cgrad          do k=1,3
4279 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4280 cgrad          enddo
4281 cgrad        enddo
4282         do k=1,3
4283           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4284           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4285         enddo
4286         endif
4287       enddo
4288       ehpb=0.5D0*ehpb
4289       return
4290       end
4291 C--------------------------------------------------------------------------
4292       subroutine ssbond_ene(i,j,eij)
4293 C
4294 C Calculate the distance and angle dependent SS-bond potential energy
4295 C using a free-energy function derived based on RHF/6-31G** ab initio
4296 C calculations of diethyl disulfide.
4297 C
4298 C A. Liwo and U. Kozlowska, 11/24/03
4299 C
4300       implicit real*8 (a-h,o-z)
4301       include 'DIMENSIONS'
4302       include 'COMMON.SBRIDGE'
4303       include 'COMMON.CHAIN'
4304       include 'COMMON.DERIV'
4305       include 'COMMON.LOCAL'
4306       include 'COMMON.INTERACT'
4307       include 'COMMON.VAR'
4308       include 'COMMON.IOUNITS'
4309       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4310       itypi=iabs(itype(i))
4311       xi=c(1,nres+i)
4312       yi=c(2,nres+i)
4313       zi=c(3,nres+i)
4314       dxi=dc_norm(1,nres+i)
4315       dyi=dc_norm(2,nres+i)
4316       dzi=dc_norm(3,nres+i)
4317 c      dsci_inv=dsc_inv(itypi)
4318       dsci_inv=vbld_inv(nres+i)
4319       itypj=iabs(itype(j))
4320 c      dscj_inv=dsc_inv(itypj)
4321       dscj_inv=vbld_inv(nres+j)
4322       xj=c(1,nres+j)-xi
4323       yj=c(2,nres+j)-yi
4324       zj=c(3,nres+j)-zi
4325       dxj=dc_norm(1,nres+j)
4326       dyj=dc_norm(2,nres+j)
4327       dzj=dc_norm(3,nres+j)
4328       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4329       rij=dsqrt(rrij)
4330       erij(1)=xj*rij
4331       erij(2)=yj*rij
4332       erij(3)=zj*rij
4333       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4334       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4335       om12=dxi*dxj+dyi*dyj+dzi*dzj
4336       do k=1,3
4337         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4338         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4339       enddo
4340       rij=1.0d0/rij
4341       deltad=rij-d0cm
4342       deltat1=1.0d0-om1
4343       deltat2=1.0d0+om2
4344       deltat12=om2-om1+2.0d0
4345       cosphi=om12-om1*om2
4346       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4347      &  +akct*deltad*deltat12
4348      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4349 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4350 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4351 c     &  " deltat12",deltat12," eij",eij
4352       ed=2*akcm*deltad+akct*deltat12
4353       pom1=akct*deltad
4354       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4355       eom1=-2*akth*deltat1-pom1-om2*pom2
4356       eom2= 2*akth*deltat2+pom1-om1*pom2
4357       eom12=pom2
4358       do k=1,3
4359         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4360         ghpbx(k,i)=ghpbx(k,i)-ggk
4361      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4362      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4363         ghpbx(k,j)=ghpbx(k,j)+ggk
4364      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4365      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4366         ghpbc(k,i)=ghpbc(k,i)-ggk
4367         ghpbc(k,j)=ghpbc(k,j)+ggk
4368       enddo
4369 C
4370 C Calculate the components of the gradient in DC and X
4371 C
4372 cgrad      do k=i,j-1
4373 cgrad        do l=1,3
4374 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4375 cgrad        enddo
4376 cgrad      enddo
4377       return
4378       end
4379 C--------------------------------------------------------------------------
4380       subroutine ebond(estr)
4381 c
4382 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4383 c
4384       implicit real*8 (a-h,o-z)
4385       include 'DIMENSIONS'
4386       include 'COMMON.LOCAL'
4387       include 'COMMON.GEO'
4388       include 'COMMON.INTERACT'
4389       include 'COMMON.DERIV'
4390       include 'COMMON.VAR'
4391       include 'COMMON.CHAIN'
4392       include 'COMMON.IOUNITS'
4393       include 'COMMON.NAMES'
4394       include 'COMMON.FFIELD'
4395       include 'COMMON.CONTROL'
4396       include 'COMMON.SETUP'
4397       double precision u(3),ud(3)
4398       estr=0.0d0
4399       do i=ibondp_start,ibondp_end
4400         diff = vbld(i)-vbldp0
4401 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4402         estr=estr+diff*diff
4403         do j=1,3
4404           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4405         enddo
4406 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4407       enddo
4408       estr=0.5d0*AKP*estr
4409 c
4410 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4411 c
4412       do i=ibond_start,ibond_end
4413         iti=iabs(itype(i))
4414         if (iti.ne.10) then
4415           nbi=nbondterm(iti)
4416           if (nbi.eq.1) then
4417             diff=vbld(i+nres)-vbldsc0(1,iti)
4418 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4419 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4420             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4421             do j=1,3
4422               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4423             enddo
4424           else
4425             do j=1,nbi
4426               diff=vbld(i+nres)-vbldsc0(j,iti)
4427               ud(j)=aksc(j,iti)*diff
4428               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4429             enddo
4430             uprod=u(1)
4431             do j=2,nbi
4432               uprod=uprod*u(j)
4433             enddo
4434             usum=0.0d0
4435             usumsqder=0.0d0
4436             do j=1,nbi
4437               uprod1=1.0d0
4438               uprod2=1.0d0
4439               do k=1,nbi
4440                 if (k.ne.j) then
4441                   uprod1=uprod1*u(k)
4442                   uprod2=uprod2*u(k)*u(k)
4443                 endif
4444               enddo
4445               usum=usum+uprod1
4446               usumsqder=usumsqder+ud(j)*uprod2
4447             enddo
4448             estr=estr+uprod/usum
4449             do j=1,3
4450              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4451             enddo
4452           endif
4453         endif
4454       enddo
4455       return
4456       end
4457 #ifdef CRYST_THETA
4458 C--------------------------------------------------------------------------
4459       subroutine ebend(etheta)
4460 C
4461 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4462 C angles gamma and its derivatives in consecutive thetas and gammas.
4463 C
4464       implicit real*8 (a-h,o-z)
4465       include 'DIMENSIONS'
4466       include 'COMMON.LOCAL'
4467       include 'COMMON.GEO'
4468       include 'COMMON.INTERACT'
4469       include 'COMMON.DERIV'
4470       include 'COMMON.VAR'
4471       include 'COMMON.CHAIN'
4472       include 'COMMON.IOUNITS'
4473       include 'COMMON.NAMES'
4474       include 'COMMON.FFIELD'
4475       include 'COMMON.CONTROL'
4476       common /calcthet/ term1,term2,termm,diffak,ratak,
4477      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4478      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4479       double precision y(2),z(2)
4480       delta=0.02d0*pi
4481 c      time11=dexp(-2*time)
4482 c      time12=1.0d0
4483       etheta=0.0D0
4484 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4485       do i=ithet_start,ithet_end
4486 C Zero the energy function and its derivative at 0 or pi.
4487         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4488         it=iabs(itype(i-1))
4489         if (i.gt.3) then
4490 #ifdef OSF
4491           phii=phi(i)
4492           if (phii.ne.phii) phii=150.0
4493 #else
4494           phii=phi(i)
4495 #endif
4496           y(1)=dcos(phii)
4497           y(2)=dsin(phii)
4498         else
4499           y(1)=0.0D0
4500           y(2)=0.0D0
4501         endif
4502         if (i.lt.nres) then
4503 #ifdef OSF
4504           phii1=phi(i+1)
4505           if (phii1.ne.phii1) phii1=150.0
4506           phii1=pinorm(phii1)
4507           z(1)=cos(phii1)
4508 #else
4509           phii1=phi(i+1)
4510           z(1)=dcos(phii1)
4511 #endif
4512           z(2)=dsin(phii1)
4513         else
4514           z(1)=0.0D0
4515           z(2)=0.0D0
4516         endif
4517 C Calculate the "mean" value of theta from the part of the distribution
4518 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4519 C In following comments this theta will be referred to as t_c.
4520         thet_pred_mean=0.0d0
4521         do k=1,2
4522           athetk=athet(k,it)
4523           bthetk=bthet(k,it)
4524           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4525         enddo
4526         dthett=thet_pred_mean*ssd
4527         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4528 C Derivatives of the "mean" values in gamma1 and gamma2.
4529         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4530         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4531         if (theta(i).gt.pi-delta) then
4532           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4533      &         E_tc0)
4534           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4535           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4536           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4537      &        E_theta)
4538           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4539      &        E_tc)
4540         else if (theta(i).lt.delta) then
4541           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4542           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4543           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4544      &        E_theta)
4545           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4546           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4547      &        E_tc)
4548         else
4549           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4550      &        E_theta,E_tc)
4551         endif
4552         etheta=etheta+ethetai
4553         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4554      &      'ebend',i,ethetai
4555         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4556         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4557         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4558       enddo
4559 C Ufff.... We've done all this!!!
4560       return
4561       end
4562 C---------------------------------------------------------------------------
4563       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4564      &     E_tc)
4565       implicit real*8 (a-h,o-z)
4566       include 'DIMENSIONS'
4567       include 'COMMON.LOCAL'
4568       include 'COMMON.IOUNITS'
4569       common /calcthet/ term1,term2,termm,diffak,ratak,
4570      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4571      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4572 C Calculate the contributions to both Gaussian lobes.
4573 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4574 C The "polynomial part" of the "standard deviation" of this part of
4575 C the distribution.
4576         sig=polthet(3,it)
4577         do j=2,0,-1
4578           sig=sig*thet_pred_mean+polthet(j,it)
4579         enddo
4580 C Derivative of the "interior part" of the "standard deviation of the"
4581 C gamma-dependent Gaussian lobe in t_c.
4582         sigtc=3*polthet(3,it)
4583         do j=2,1,-1
4584           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4585         enddo
4586         sigtc=sig*sigtc
4587 C Set the parameters of both Gaussian lobes of the distribution.
4588 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4589         fac=sig*sig+sigc0(it)
4590         sigcsq=fac+fac
4591         sigc=1.0D0/sigcsq
4592 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4593         sigsqtc=-4.0D0*sigcsq*sigtc
4594 c       print *,i,sig,sigtc,sigsqtc
4595 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4596         sigtc=-sigtc/(fac*fac)
4597 C Following variable is sigma(t_c)**(-2)
4598         sigcsq=sigcsq*sigcsq
4599         sig0i=sig0(it)
4600         sig0inv=1.0D0/sig0i**2
4601         delthec=thetai-thet_pred_mean
4602         delthe0=thetai-theta0i
4603         term1=-0.5D0*sigcsq*delthec*delthec
4604         term2=-0.5D0*sig0inv*delthe0*delthe0
4605 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4606 C NaNs in taking the logarithm. We extract the largest exponent which is added
4607 C to the energy (this being the log of the distribution) at the end of energy
4608 C term evaluation for this virtual-bond angle.
4609         if (term1.gt.term2) then
4610           termm=term1
4611           term2=dexp(term2-termm)
4612           term1=1.0d0
4613         else
4614           termm=term2
4615           term1=dexp(term1-termm)
4616           term2=1.0d0
4617         endif
4618 C The ratio between the gamma-independent and gamma-dependent lobes of
4619 C the distribution is a Gaussian function of thet_pred_mean too.
4620         diffak=gthet(2,it)-thet_pred_mean
4621         ratak=diffak/gthet(3,it)**2
4622         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4623 C Let's differentiate it in thet_pred_mean NOW.
4624         aktc=ak*ratak
4625 C Now put together the distribution terms to make complete distribution.
4626         termexp=term1+ak*term2
4627         termpre=sigc+ak*sig0i
4628 C Contribution of the bending energy from this theta is just the -log of
4629 C the sum of the contributions from the two lobes and the pre-exponential
4630 C factor. Simple enough, isn't it?
4631         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4632 C NOW the derivatives!!!
4633 C 6/6/97 Take into account the deformation.
4634         E_theta=(delthec*sigcsq*term1
4635      &       +ak*delthe0*sig0inv*term2)/termexp
4636         E_tc=((sigtc+aktc*sig0i)/termpre
4637      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4638      &       aktc*term2)/termexp)
4639       return
4640       end
4641 c-----------------------------------------------------------------------------
4642       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4643       implicit real*8 (a-h,o-z)
4644       include 'DIMENSIONS'
4645       include 'COMMON.LOCAL'
4646       include 'COMMON.IOUNITS'
4647       common /calcthet/ term1,term2,termm,diffak,ratak,
4648      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4649      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4650       delthec=thetai-thet_pred_mean
4651       delthe0=thetai-theta0i
4652 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4653       t3 = thetai-thet_pred_mean
4654       t6 = t3**2
4655       t9 = term1
4656       t12 = t3*sigcsq
4657       t14 = t12+t6*sigsqtc
4658       t16 = 1.0d0
4659       t21 = thetai-theta0i
4660       t23 = t21**2
4661       t26 = term2
4662       t27 = t21*t26
4663       t32 = termexp
4664       t40 = t32**2
4665       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4666      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4667      & *(-t12*t9-ak*sig0inv*t27)
4668       return
4669       end
4670 #else
4671 C--------------------------------------------------------------------------
4672       subroutine ebend(etheta)
4673 C
4674 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4675 C angles gamma and its derivatives in consecutive thetas and gammas.
4676 C ab initio-derived potentials from
4677 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4678 C
4679       implicit real*8 (a-h,o-z)
4680       include 'DIMENSIONS'
4681       include 'COMMON.LOCAL'
4682       include 'COMMON.GEO'
4683       include 'COMMON.INTERACT'
4684       include 'COMMON.DERIV'
4685       include 'COMMON.VAR'
4686       include 'COMMON.CHAIN'
4687       include 'COMMON.IOUNITS'
4688       include 'COMMON.NAMES'
4689       include 'COMMON.FFIELD'
4690       include 'COMMON.CONTROL'
4691       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4692      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4693      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4694      & sinph1ph2(maxdouble,maxdouble)
4695       logical lprn /.false./, lprn1 /.false./
4696       etheta=0.0D0
4697       do i=ithet_start,ithet_end
4698         dethetai=0.0d0
4699         dephii=0.0d0
4700         dephii1=0.0d0
4701         theti2=0.5d0*theta(i)
4702         ityp2=ithetyp(iabs(itype(i-1)))
4703         do k=1,nntheterm
4704           coskt(k)=dcos(k*theti2)
4705           sinkt(k)=dsin(k*theti2)
4706         enddo
4707         if (i.gt.3) then
4708 #ifdef OSF
4709           phii=phi(i)
4710           if (phii.ne.phii) phii=150.0
4711 #else
4712           phii=phi(i)
4713 #endif
4714           ityp1=ithetyp(iabs(itype(i-2)))
4715           do k=1,nsingle
4716             cosph1(k)=dcos(k*phii)
4717             sinph1(k)=dsin(k*phii)
4718           enddo
4719         else
4720           phii=0.0d0
4721           ityp1=nthetyp+1
4722           do k=1,nsingle
4723             cosph1(k)=0.0d0
4724             sinph1(k)=0.0d0
4725           enddo
4726         endif
4727         if (i.lt.nres) then
4728 #ifdef OSF
4729           phii1=phi(i+1)
4730           if (phii1.ne.phii1) phii1=150.0
4731           phii1=pinorm(phii1)
4732 #else
4733           phii1=phi(i+1)
4734 #endif
4735           ityp3=ithetyp(iabs(itype(i)))
4736           do k=1,nsingle
4737             cosph2(k)=dcos(k*phii1)
4738             sinph2(k)=dsin(k*phii1)
4739           enddo
4740         else
4741           phii1=0.0d0
4742           ityp3=nthetyp+1
4743           do k=1,nsingle
4744             cosph2(k)=0.0d0
4745             sinph2(k)=0.0d0
4746           enddo
4747         endif
4748         ethetai=aa0thet(ityp1,ityp2,ityp3)
4749         do k=1,ndouble
4750           do l=1,k-1
4751             ccl=cosph1(l)*cosph2(k-l)
4752             ssl=sinph1(l)*sinph2(k-l)
4753             scl=sinph1(l)*cosph2(k-l)
4754             csl=cosph1(l)*sinph2(k-l)
4755             cosph1ph2(l,k)=ccl-ssl
4756             cosph1ph2(k,l)=ccl+ssl
4757             sinph1ph2(l,k)=scl+csl
4758             sinph1ph2(k,l)=scl-csl
4759           enddo
4760         enddo
4761         if (lprn) then
4762         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4763      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4764         write (iout,*) "coskt and sinkt"
4765         do k=1,nntheterm
4766           write (iout,*) k,coskt(k),sinkt(k)
4767         enddo
4768         endif
4769         do k=1,ntheterm
4770           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4771           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4772      &      *coskt(k)
4773           if (lprn)
4774      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4775      &     " ethetai",ethetai
4776         enddo
4777         if (lprn) then
4778         write (iout,*) "cosph and sinph"
4779         do k=1,nsingle
4780           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4781         enddo
4782         write (iout,*) "cosph1ph2 and sinph2ph2"
4783         do k=2,ndouble
4784           do l=1,k-1
4785             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4786      &         sinph1ph2(l,k),sinph1ph2(k,l)
4787           enddo
4788         enddo
4789         write(iout,*) "ethetai",ethetai
4790         endif
4791         do m=1,ntheterm2
4792           do k=1,nsingle
4793             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4794      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4795      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4796      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4797             ethetai=ethetai+sinkt(m)*aux
4798             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4799             dephii=dephii+k*sinkt(m)*(
4800      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4801      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4802             dephii1=dephii1+k*sinkt(m)*(
4803      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4804      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4805             if (lprn)
4806      &      write (iout,*) "m",m," k",k," bbthet",
4807      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4808      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4809      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4810      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4811           enddo
4812         enddo
4813         if (lprn)
4814      &  write(iout,*) "ethetai",ethetai
4815         do m=1,ntheterm3
4816           do k=2,ndouble
4817             do l=1,k-1
4818               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4819      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4820      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4821      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4822               ethetai=ethetai+sinkt(m)*aux
4823               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4824               dephii=dephii+l*sinkt(m)*(
4825      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4826      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4827      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4828      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4829               dephii1=dephii1+(k-l)*sinkt(m)*(
4830      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4831      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4832      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4833      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4834               if (lprn) then
4835               write (iout,*) "m",m," k",k," l",l," ffthet",
4836      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4837      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4838      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4839      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4840               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4841      &            cosph1ph2(k,l)*sinkt(m),
4842      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4843               endif
4844             enddo
4845           enddo
4846         enddo
4847 10      continue
4848         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4849      &   i,theta(i)*rad2deg,phii*rad2deg,
4850      &   phii1*rad2deg,ethetai
4851         etheta=etheta+ethetai
4852         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4853         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4854         gloc(nphi+i-2,icg)=wang*dethetai
4855       enddo
4856       return
4857       end
4858 #endif
4859 #ifdef CRYST_SC
4860 c-----------------------------------------------------------------------------
4861       subroutine esc(escloc)
4862 C Calculate the local energy of a side chain and its derivatives in the
4863 C corresponding virtual-bond valence angles THETA and the spherical angles
4864 C ALPHA and OMEGA.
4865       implicit real*8 (a-h,o-z)
4866       include 'DIMENSIONS'
4867       include 'COMMON.GEO'
4868       include 'COMMON.LOCAL'
4869       include 'COMMON.VAR'
4870       include 'COMMON.INTERACT'
4871       include 'COMMON.DERIV'
4872       include 'COMMON.CHAIN'
4873       include 'COMMON.IOUNITS'
4874       include 'COMMON.NAMES'
4875       include 'COMMON.FFIELD'
4876       include 'COMMON.CONTROL'
4877       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4878      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4879       common /sccalc/ time11,time12,time112,theti,it,nlobit
4880       delta=0.02d0*pi
4881       escloc=0.0D0
4882 c     write (iout,'(a)') 'ESC'
4883       do i=loc_start,loc_end
4884         it=itype(i)
4885         if (it.eq.10) goto 1
4886         nlobit=nlob(iabs(it))
4887 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4888 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4889         theti=theta(i+1)-pipol
4890         x(1)=dtan(theti)
4891         x(2)=alph(i)
4892         x(3)=omeg(i)
4893
4894         if (x(2).gt.pi-delta) then
4895           xtemp(1)=x(1)
4896           xtemp(2)=pi-delta
4897           xtemp(3)=x(3)
4898           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4899           xtemp(2)=pi
4900           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4901           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4902      &        escloci,dersc(2))
4903           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4904      &        ddersc0(1),dersc(1))
4905           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4906      &        ddersc0(3),dersc(3))
4907           xtemp(2)=pi-delta
4908           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4909           xtemp(2)=pi
4910           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4911           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4912      &            dersc0(2),esclocbi,dersc02)
4913           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4914      &            dersc12,dersc01)
4915           call splinthet(x(2),0.5d0*delta,ss,ssd)
4916           dersc0(1)=dersc01
4917           dersc0(2)=dersc02
4918           dersc0(3)=0.0d0
4919           do k=1,3
4920             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4921           enddo
4922           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4923 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4924 c    &             esclocbi,ss,ssd
4925           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4926 c         escloci=esclocbi
4927 c         write (iout,*) escloci
4928         else if (x(2).lt.delta) then
4929           xtemp(1)=x(1)
4930           xtemp(2)=delta
4931           xtemp(3)=x(3)
4932           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4933           xtemp(2)=0.0d0
4934           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4935           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4936      &        escloci,dersc(2))
4937           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4938      &        ddersc0(1),dersc(1))
4939           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4940      &        ddersc0(3),dersc(3))
4941           xtemp(2)=delta
4942           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4943           xtemp(2)=0.0d0
4944           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4945           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4946      &            dersc0(2),esclocbi,dersc02)
4947           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4948      &            dersc12,dersc01)
4949           dersc0(1)=dersc01
4950           dersc0(2)=dersc02
4951           dersc0(3)=0.0d0
4952           call splinthet(x(2),0.5d0*delta,ss,ssd)
4953           do k=1,3
4954             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4955           enddo
4956           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4957 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4958 c    &             esclocbi,ss,ssd
4959           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4960 c         write (iout,*) escloci
4961         else
4962           call enesc(x,escloci,dersc,ddummy,.false.)
4963         endif
4964
4965         escloc=escloc+escloci
4966         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4967      &     'escloc',i,escloci
4968 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4969
4970         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4971      &   wscloc*dersc(1)
4972         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4973         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4974     1   continue
4975       enddo
4976       return
4977       end
4978 C---------------------------------------------------------------------------
4979       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4980       implicit real*8 (a-h,o-z)
4981       include 'DIMENSIONS'
4982       include 'COMMON.GEO'
4983       include 'COMMON.LOCAL'
4984       include 'COMMON.IOUNITS'
4985       common /sccalc/ time11,time12,time112,theti,it,nlobit
4986       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4987       double precision contr(maxlob,-1:1)
4988       logical mixed
4989 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4990         escloc_i=0.0D0
4991         do j=1,3
4992           dersc(j)=0.0D0
4993           if (mixed) ddersc(j)=0.0d0
4994         enddo
4995         x3=x(3)
4996
4997 C Because of periodicity of the dependence of the SC energy in omega we have
4998 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4999 C To avoid underflows, first compute & store the exponents.
5000
5001         do iii=-1,1
5002
5003           x(3)=x3+iii*dwapi
5004
5005           do j=1,nlobit
5006             do k=1,3
5007               z(k)=x(k)-censc(k,j,it)
5008             enddo
5009             do k=1,3
5010               Axk=0.0D0
5011               do l=1,3
5012                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5013               enddo
5014               Ax(k,j,iii)=Axk
5015             enddo
5016             expfac=0.0D0
5017             do k=1,3
5018               expfac=expfac+Ax(k,j,iii)*z(k)
5019             enddo
5020             contr(j,iii)=expfac
5021           enddo ! j
5022
5023         enddo ! iii
5024
5025         x(3)=x3
5026 C As in the case of ebend, we want to avoid underflows in exponentiation and
5027 C subsequent NaNs and INFs in energy calculation.
5028 C Find the largest exponent
5029         emin=contr(1,-1)
5030         do iii=-1,1
5031           do j=1,nlobit
5032             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5033           enddo
5034         enddo
5035         emin=0.5D0*emin
5036 cd      print *,'it=',it,' emin=',emin
5037
5038 C Compute the contribution to SC energy and derivatives
5039         do iii=-1,1
5040
5041           do j=1,nlobit
5042 #ifdef OSF
5043             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5044             if(adexp.ne.adexp) adexp=1.0
5045             expfac=dexp(adexp)
5046 #else
5047             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5048 #endif
5049 cd          print *,'j=',j,' expfac=',expfac
5050             escloc_i=escloc_i+expfac
5051             do k=1,3
5052               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5053             enddo
5054             if (mixed) then
5055               do k=1,3,2
5056                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5057      &            +gaussc(k,2,j,it))*expfac
5058               enddo
5059             endif
5060           enddo
5061
5062         enddo ! iii
5063
5064         dersc(1)=dersc(1)/cos(theti)**2
5065         ddersc(1)=ddersc(1)/cos(theti)**2
5066         ddersc(3)=ddersc(3)
5067
5068         escloci=-(dlog(escloc_i)-emin)
5069         do j=1,3
5070           dersc(j)=dersc(j)/escloc_i
5071         enddo
5072         if (mixed) then
5073           do j=1,3,2
5074             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5075           enddo
5076         endif
5077       return
5078       end
5079 C------------------------------------------------------------------------------
5080       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5081       implicit real*8 (a-h,o-z)
5082       include 'DIMENSIONS'
5083       include 'COMMON.GEO'
5084       include 'COMMON.LOCAL'
5085       include 'COMMON.IOUNITS'
5086       common /sccalc/ time11,time12,time112,theti,it,nlobit
5087       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5088       double precision contr(maxlob)
5089       logical mixed
5090
5091       escloc_i=0.0D0
5092
5093       do j=1,3
5094         dersc(j)=0.0D0
5095       enddo
5096
5097       do j=1,nlobit
5098         do k=1,2
5099           z(k)=x(k)-censc(k,j,it)
5100         enddo
5101         z(3)=dwapi
5102         do k=1,3
5103           Axk=0.0D0
5104           do l=1,3
5105             Axk=Axk+gaussc(l,k,j,it)*z(l)
5106           enddo
5107           Ax(k,j)=Axk
5108         enddo
5109         expfac=0.0D0
5110         do k=1,3
5111           expfac=expfac+Ax(k,j)*z(k)
5112         enddo
5113         contr(j)=expfac
5114       enddo ! j
5115
5116 C As in the case of ebend, we want to avoid underflows in exponentiation and
5117 C subsequent NaNs and INFs in energy calculation.
5118 C Find the largest exponent
5119       emin=contr(1)
5120       do j=1,nlobit
5121         if (emin.gt.contr(j)) emin=contr(j)
5122       enddo
5123       emin=0.5D0*emin
5124
5125 C Compute the contribution to SC energy and derivatives
5126
5127       dersc12=0.0d0
5128       do j=1,nlobit
5129         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5130         escloc_i=escloc_i+expfac
5131         do k=1,2
5132           dersc(k)=dersc(k)+Ax(k,j)*expfac
5133         enddo
5134         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5135      &            +gaussc(1,2,j,it))*expfac
5136         dersc(3)=0.0d0
5137       enddo
5138
5139       dersc(1)=dersc(1)/cos(theti)**2
5140       dersc12=dersc12/cos(theti)**2
5141       escloci=-(dlog(escloc_i)-emin)
5142       do j=1,2
5143         dersc(j)=dersc(j)/escloc_i
5144       enddo
5145       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5146       return
5147       end
5148 #else
5149 c----------------------------------------------------------------------------------
5150       subroutine esc(escloc)
5151 C Calculate the local energy of a side chain and its derivatives in the
5152 C corresponding virtual-bond valence angles THETA and the spherical angles
5153 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5154 C added by Urszula Kozlowska. 07/11/2007
5155 C
5156       implicit real*8 (a-h,o-z)
5157       include 'DIMENSIONS'
5158       include 'COMMON.GEO'
5159       include 'COMMON.LOCAL'
5160       include 'COMMON.VAR'
5161       include 'COMMON.SCROT'
5162       include 'COMMON.INTERACT'
5163       include 'COMMON.DERIV'
5164       include 'COMMON.CHAIN'
5165       include 'COMMON.IOUNITS'
5166       include 'COMMON.NAMES'
5167       include 'COMMON.FFIELD'
5168       include 'COMMON.CONTROL'
5169       include 'COMMON.VECTORS'
5170       double precision x_prime(3),y_prime(3),z_prime(3)
5171      &    , sumene,dsc_i,dp2_i,x(65),
5172      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5173      &    de_dxx,de_dyy,de_dzz,de_dt
5174       double precision s1_t,s1_6_t,s2_t,s2_6_t
5175       double precision
5176      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5177      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5178      & dt_dCi(3),dt_dCi1(3)
5179       common /sccalc/ time11,time12,time112,theti,it,nlobit
5180       delta=0.02d0*pi
5181       escloc=0.0D0
5182       do i=loc_start,loc_end
5183         costtab(i+1) =dcos(theta(i+1))
5184         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5185         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5186         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5187         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5188         cosfac=dsqrt(cosfac2)
5189         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5190         sinfac=dsqrt(sinfac2)
5191         it=itype(i)
5192         if (it.eq.10) goto 1
5193 c
5194 C  Compute the axes of tghe local cartesian coordinates system; store in
5195 c   x_prime, y_prime and z_prime
5196 c
5197         do j=1,3
5198           x_prime(j) = 0.00
5199           y_prime(j) = 0.00
5200           z_prime(j) = 0.00
5201         enddo
5202 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5203 C     &   dc_norm(3,i+nres)
5204         do j = 1,3
5205           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5206           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5207         enddo
5208         do j = 1,3
5209           z_prime(j) = -uz(j,i-1)
5210         enddo
5211 c       write (2,*) "i",i
5212 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5213 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5214 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5215 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5216 c      & " xy",scalar(x_prime(1),y_prime(1)),
5217 c      & " xz",scalar(x_prime(1),z_prime(1)),
5218 c      & " yy",scalar(y_prime(1),y_prime(1)),
5219 c      & " yz",scalar(y_prime(1),z_prime(1)),
5220 c      & " zz",scalar(z_prime(1),z_prime(1))
5221 c
5222 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5223 C to local coordinate system. Store in xx, yy, zz.
5224 c
5225         xx=0.0d0
5226         yy=0.0d0
5227         zz=0.0d0
5228         do j = 1,3
5229           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5230           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5231           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5232         enddo
5233
5234         xxtab(i)=xx
5235         yytab(i)=yy
5236         zztab(i)=zz
5237 C
5238 C Compute the energy of the ith side cbain
5239 C
5240 c        write (2,*) "xx",xx," yy",yy," zz",zz
5241         it=itype(i)
5242         do j = 1,65
5243           x(j) = sc_parmin(j,it)
5244         enddo
5245 #ifdef CHECK_COORD
5246 Cc diagnostics - remove later
5247         xx1 = dcos(alph(2))
5248         yy1 = dsin(alph(2))*dcos(omeg(2))
5249         zz1 = -dsin(alph(2))*dsin(omeg(2))
5250         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5251      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5252      &    xx1,yy1,zz1
5253 C,"  --- ", xx_w,yy_w,zz_w
5254 c end diagnostics
5255 #endif
5256         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5257      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5258      &   + x(10)*yy*zz
5259         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5260      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5261      & + x(20)*yy*zz
5262         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5263      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5264      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5265      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5266      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5267      &  +x(40)*xx*yy*zz
5268         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5269      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5270      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5271      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5272      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5273      &  +x(60)*xx*yy*zz
5274         dsc_i   = 0.743d0+x(61)
5275         dp2_i   = 1.9d0+x(62)
5276         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5277      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5278         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5279      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5280         s1=(1+x(63))/(0.1d0 + dscp1)
5281         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5282         s2=(1+x(65))/(0.1d0 + dscp2)
5283         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5284         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5285      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5286 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5287 c     &   sumene4,
5288 c     &   dscp1,dscp2,sumene
5289 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5290         escloc = escloc + sumene
5291 c        write (2,*) "i",i," escloc",sumene,escloc
5292 #ifdef DEBUG
5293 C
5294 C This section to check the numerical derivatives of the energy of ith side
5295 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5296 C #define DEBUG in the code to turn it on.
5297 C
5298         write (2,*) "sumene               =",sumene
5299         aincr=1.0d-7
5300         xxsave=xx
5301         xx=xx+aincr
5302         write (2,*) xx,yy,zz
5303         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5304         de_dxx_num=(sumenep-sumene)/aincr
5305         xx=xxsave
5306         write (2,*) "xx+ sumene from enesc=",sumenep
5307         yysave=yy
5308         yy=yy+aincr
5309         write (2,*) xx,yy,zz
5310         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5311         de_dyy_num=(sumenep-sumene)/aincr
5312         yy=yysave
5313         write (2,*) "yy+ sumene from enesc=",sumenep
5314         zzsave=zz
5315         zz=zz+aincr
5316         write (2,*) xx,yy,zz
5317         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5318         de_dzz_num=(sumenep-sumene)/aincr
5319         zz=zzsave
5320         write (2,*) "zz+ sumene from enesc=",sumenep
5321         costsave=cost2tab(i+1)
5322         sintsave=sint2tab(i+1)
5323         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5324         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5325         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5326         de_dt_num=(sumenep-sumene)/aincr
5327         write (2,*) " t+ sumene from enesc=",sumenep
5328         cost2tab(i+1)=costsave
5329         sint2tab(i+1)=sintsave
5330 C End of diagnostics section.
5331 #endif
5332 C
5333 C Compute the gradient of esc
5334 C
5335         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5336         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5337         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5338         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5339         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5340         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5341         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5342         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5343         pom1=(sumene3*sint2tab(i+1)+sumene1)
5344      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5345         pom2=(sumene4*cost2tab(i+1)+sumene2)
5346      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5347         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5348         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5349      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5350      &  +x(40)*yy*zz
5351         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5352         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5353      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5354      &  +x(60)*yy*zz
5355         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5356      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5357      &        +(pom1+pom2)*pom_dx
5358 #ifdef DEBUG
5359         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5360 #endif
5361 C
5362         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5363         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5364      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5365      &  +x(40)*xx*zz
5366         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5367         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5368      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5369      &  +x(59)*zz**2 +x(60)*xx*zz
5370         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5371      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5372      &        +(pom1-pom2)*pom_dy
5373 #ifdef DEBUG
5374         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5375 #endif
5376 C
5377         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5378      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5379      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5380      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5381      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5382      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5383      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5384      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5385 #ifdef DEBUG
5386         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5387 #endif
5388 C
5389         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5390      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5391      &  +pom1*pom_dt1+pom2*pom_dt2
5392 #ifdef DEBUG
5393         write(2,*), "de_dt = ", de_dt,de_dt_num
5394 #endif
5395 c
5396 C
5397        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5398        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5399        cosfac2xx=cosfac2*xx
5400        sinfac2yy=sinfac2*yy
5401        do k = 1,3
5402          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5403      &      vbld_inv(i+1)
5404          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5405      &      vbld_inv(i)
5406          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5407          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5408 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5409 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5410 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5411 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5412          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5413          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5414          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5415          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5416          dZZ_Ci1(k)=0.0d0
5417          dZZ_Ci(k)=0.0d0
5418          do j=1,3
5419            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5420            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5421          enddo
5422
5423          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5424          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5425          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5426 c
5427          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5428          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5429        enddo
5430
5431        do k=1,3
5432          dXX_Ctab(k,i)=dXX_Ci(k)
5433          dXX_C1tab(k,i)=dXX_Ci1(k)
5434          dYY_Ctab(k,i)=dYY_Ci(k)
5435          dYY_C1tab(k,i)=dYY_Ci1(k)
5436          dZZ_Ctab(k,i)=dZZ_Ci(k)
5437          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5438          dXX_XYZtab(k,i)=dXX_XYZ(k)
5439          dYY_XYZtab(k,i)=dYY_XYZ(k)
5440          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5441        enddo
5442
5443        do k = 1,3
5444 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5445 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5446 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5447 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5448 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5449 c     &    dt_dci(k)
5450 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5451 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5452          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5453      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5454          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5455      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5456          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5457      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5458        enddo
5459 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5460 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5461
5462 C to check gradient call subroutine check_grad
5463
5464     1 continue
5465       enddo
5466       return
5467       end
5468 c------------------------------------------------------------------------------
5469       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5470       implicit none
5471       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5472      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5473       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5474      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5475      &   + x(10)*yy*zz
5476       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5477      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5478      & + x(20)*yy*zz
5479       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5480      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5481      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5482      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5483      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5484      &  +x(40)*xx*yy*zz
5485       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5486      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5487      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5488      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5489      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5490      &  +x(60)*xx*yy*zz
5491       dsc_i   = 0.743d0+x(61)
5492       dp2_i   = 1.9d0+x(62)
5493       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5494      &          *(xx*cost2+yy*sint2))
5495       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5496      &          *(xx*cost2-yy*sint2))
5497       s1=(1+x(63))/(0.1d0 + dscp1)
5498       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5499       s2=(1+x(65))/(0.1d0 + dscp2)
5500       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5501       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5502      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5503       enesc=sumene
5504       return
5505       end
5506 #endif
5507 c------------------------------------------------------------------------------
5508       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5509 C
5510 C This procedure calculates two-body contact function g(rij) and its derivative:
5511 C
5512 C           eps0ij                                     !       x < -1
5513 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5514 C            0                                         !       x > 1
5515 C
5516 C where x=(rij-r0ij)/delta
5517 C
5518 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5519 C
5520       implicit none
5521       double precision rij,r0ij,eps0ij,fcont,fprimcont
5522       double precision x,x2,x4,delta
5523 c     delta=0.02D0*r0ij
5524 c      delta=0.2D0*r0ij
5525       x=(rij-r0ij)/delta
5526       if (x.lt.-1.0D0) then
5527         fcont=eps0ij
5528         fprimcont=0.0D0
5529       else if (x.le.1.0D0) then
5530         x2=x*x
5531         x4=x2*x2
5532         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5533         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5534       else
5535         fcont=0.0D0
5536         fprimcont=0.0D0
5537       endif
5538       return
5539       end
5540 c------------------------------------------------------------------------------
5541       subroutine splinthet(theti,delta,ss,ssder)
5542       implicit real*8 (a-h,o-z)
5543       include 'DIMENSIONS'
5544       include 'COMMON.VAR'
5545       include 'COMMON.GEO'
5546       thetup=pi-delta
5547       thetlow=delta
5548       if (theti.gt.pipol) then
5549         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5550       else
5551         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5552         ssder=-ssder
5553       endif
5554       return
5555       end
5556 c------------------------------------------------------------------------------
5557       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5558       implicit none
5559       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5560       double precision ksi,ksi2,ksi3,a1,a2,a3
5561       a1=fprim0*delta/(f1-f0)
5562       a2=3.0d0-2.0d0*a1
5563       a3=a1-2.0d0
5564       ksi=(x-x0)/delta
5565       ksi2=ksi*ksi
5566       ksi3=ksi2*ksi
5567       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5568       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5569       return
5570       end
5571 c------------------------------------------------------------------------------
5572       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5573       implicit none
5574       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5575       double precision ksi,ksi2,ksi3,a1,a2,a3
5576       ksi=(x-x0)/delta
5577       ksi2=ksi*ksi
5578       ksi3=ksi2*ksi
5579       a1=fprim0x*delta
5580       a2=3*(f1x-f0x)-2*fprim0x*delta
5581       a3=fprim0x*delta-2*(f1x-f0x)
5582       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5583       return
5584       end
5585 C-----------------------------------------------------------------------------
5586 #ifdef CRYST_TOR
5587 C-----------------------------------------------------------------------------
5588       subroutine etor(etors,edihcnstr)
5589       implicit real*8 (a-h,o-z)
5590       include 'DIMENSIONS'
5591       include 'COMMON.VAR'
5592       include 'COMMON.GEO'
5593       include 'COMMON.LOCAL'
5594       include 'COMMON.TORSION'
5595       include 'COMMON.INTERACT'
5596       include 'COMMON.DERIV'
5597       include 'COMMON.CHAIN'
5598       include 'COMMON.NAMES'
5599       include 'COMMON.IOUNITS'
5600       include 'COMMON.FFIELD'
5601       include 'COMMON.TORCNSTR'
5602       include 'COMMON.CONTROL'
5603       logical lprn
5604 C Set lprn=.true. for debugging
5605       lprn=.false.
5606 c      lprn=.true.
5607       etors=0.0D0
5608       do i=iphi_start,iphi_end
5609       etors_ii=0.0D0
5610         itori=itortyp(itype(i-2))
5611         itori1=itortyp(itype(i-1))
5612         if (iabs(itype(i)).eq.20) then
5613         iblock=2
5614         else
5615         iblock=1
5616         endif
5617         phii=phi(i)
5618         gloci=0.0D0
5619 C Proline-Proline pair is a special case...
5620         if (itori.eq.3 .and. itori1.eq.3) then
5621           if (phii.gt.-dwapi3) then
5622             cosphi=dcos(3*phii)
5623             fac=1.0D0/(1.0D0-cosphi)
5624             etorsi=v1(1,3,3)*fac
5625             etorsi=etorsi+etorsi
5626             etors=etors+etorsi-v1(1,3,3)
5627             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5628             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5629           endif
5630           do j=1,3
5631             v1ij=v1(j+1,itori,itori1)
5632             v2ij=v2(j+1,itori,itori1)
5633             cosphi=dcos(j*phii)
5634             sinphi=dsin(j*phii)
5635             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5636             if (energy_dec) etors_ii=etors_ii+
5637      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5638             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5639           enddo
5640         else
5641           do j=1,nterm_old
5642             v1ij=v1(j,itori,itori1)
5643             v2ij=v2(j,itori,itori1)
5644             cosphi=dcos(j*phii)
5645             sinphi=dsin(j*phii)
5646             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5647             if (energy_dec) etors_ii=etors_ii+
5648      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5649             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5650           enddo
5651         endif
5652         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5653      &        'etor',i,etors_ii
5654         if (lprn)
5655      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5656      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5657      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5658         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5659 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5660       enddo
5661 ! 6/20/98 - dihedral angle constraints
5662       edihcnstr=0.0d0
5663       do i=1,ndih_constr
5664         itori=idih_constr(i)
5665         phii=phi(itori)
5666         difi=phii-phi0(i)
5667         if (difi.gt.drange(i)) then
5668           difi=difi-drange(i)
5669           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5670           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5671         else if (difi.lt.-drange(i)) then
5672           difi=difi+drange(i)
5673           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5674           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5675         endif
5676 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5677 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5678       enddo
5679 !      write (iout,*) 'edihcnstr',edihcnstr
5680       return
5681       end
5682 c------------------------------------------------------------------------------
5683       subroutine etor_d(etors_d)
5684       etors_d=0.0d0
5685       return
5686       end
5687 c----------------------------------------------------------------------------
5688 #else
5689       subroutine etor(etors,edihcnstr)
5690       implicit real*8 (a-h,o-z)
5691       include 'DIMENSIONS'
5692       include 'COMMON.VAR'
5693       include 'COMMON.GEO'
5694       include 'COMMON.LOCAL'
5695       include 'COMMON.TORSION'
5696       include 'COMMON.INTERACT'
5697       include 'COMMON.DERIV'
5698       include 'COMMON.CHAIN'
5699       include 'COMMON.NAMES'
5700       include 'COMMON.IOUNITS'
5701       include 'COMMON.FFIELD'
5702       include 'COMMON.TORCNSTR'
5703       include 'COMMON.CONTROL'
5704       logical lprn
5705 C Set lprn=.true. for debugging
5706       lprn=.false.
5707 c     lprn=.true.
5708       etors=0.0D0
5709       do i=iphi_start,iphi_end
5710       etors_ii=0.0D0
5711         itori=itortyp(itype(i-2))
5712         itori1=itortyp(itype(i-1))
5713         phii=phi(i)
5714         gloci=0.0D0
5715 C Regular cosine and sine terms
5716         do j=1,nterm(itori,itori1,iblock)
5717           v1ij=v1(j,itori,itori1,iblock)
5718           v2ij=v2(j,itori,itori1,iblock)
5719           cosphi=dcos(j*phii)
5720           sinphi=dsin(j*phii)
5721           etors=etors+v1ij*cosphi+v2ij*sinphi
5722           if (energy_dec) etors_ii=etors_ii+
5723      &                v1ij*cosphi+v2ij*sinphi
5724           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5725         enddo
5726 C Lorentz terms
5727 C                         v1
5728 C  E = SUM ----------------------------------- - v1
5729 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5730 C
5731         cosphi=dcos(0.5d0*phii)
5732         sinphi=dsin(0.5d0*phii)
5733         do j=1,nlor(itori,itori1,iblock)
5734           vl1ij=vlor1(j,itori,itori1)
5735           vl2ij=vlor2(j,itori,itori1)
5736           vl3ij=vlor3(j,itori,itori1)
5737           pom=vl2ij*cosphi+vl3ij*sinphi
5738           pom1=1.0d0/(pom*pom+1.0d0)
5739           etors=etors+vl1ij*pom1
5740           if (energy_dec) etors_ii=etors_ii+
5741      &                vl1ij*pom1
5742           pom=-pom*pom1*pom1
5743           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5744         enddo
5745 C Subtract the constant term
5746         etors=etors-v0(itori,itori1,iblock)
5747           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5748      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5749         if (lprn)
5750      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5751      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5752      &  (v1(j,itori,itori1,iblock),j=1,6),
5753      &  (v2(j,itori,itori1,iblock),j=1,6)
5754         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5755 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5756       enddo
5757 ! 6/20/98 - dihedral angle constraints
5758       edihcnstr=0.0d0
5759 c      do i=1,ndih_constr
5760       do i=idihconstr_start,idihconstr_end
5761         itori=idih_constr(i)
5762         phii=phi(itori)
5763         difi=pinorm(phii-phi0(i))
5764         if (difi.gt.drange(i)) then
5765           difi=difi-drange(i)
5766           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5767           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5768         else if (difi.lt.-drange(i)) then
5769           difi=difi+drange(i)
5770           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5771           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5772         else
5773           difi=0.0
5774         endif
5775 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5776 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5777 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5778       enddo
5779 cd       write (iout,*) 'edihcnstr',edihcnstr
5780       return
5781       end
5782 c----------------------------------------------------------------------------
5783       subroutine etor_d(etors_d)
5784 C 6/23/01 Compute double torsional energy
5785       implicit real*8 (a-h,o-z)
5786       include 'DIMENSIONS'
5787       include 'COMMON.VAR'
5788       include 'COMMON.GEO'
5789       include 'COMMON.LOCAL'
5790       include 'COMMON.TORSION'
5791       include 'COMMON.INTERACT'
5792       include 'COMMON.DERIV'
5793       include 'COMMON.CHAIN'
5794       include 'COMMON.NAMES'
5795       include 'COMMON.IOUNITS'
5796       include 'COMMON.FFIELD'
5797       include 'COMMON.TORCNSTR'
5798       logical lprn
5799 C Set lprn=.true. for debugging
5800       lprn=.false.
5801 c     lprn=.true.
5802       etors_d=0.0D0
5803       do i=iphid_start,iphid_end
5804         itori=itortyp(itype(i-2))
5805         itori1=itortyp(itype(i-1))
5806         itori2=itortyp(itype(i))
5807         iblock=1
5808         if (iabs(itype(i+1).eq.20)) iblock=2
5809         phii=phi(i)
5810         phii1=phi(i+1)
5811         gloci1=0.0D0
5812         gloci2=0.0D0
5813 C Regular cosine and sine terms
5814         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5815           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5816           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5817           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5818           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5819           cosphi1=dcos(j*phii)
5820           sinphi1=dsin(j*phii)
5821           cosphi2=dcos(j*phii1)
5822           sinphi2=dsin(j*phii1)
5823           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5824      &     v2cij*cosphi2+v2sij*sinphi2
5825           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5826           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5827         enddo
5828         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5829           do l=1,k-1
5830             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5831             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5832             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5833             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5834             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5835             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5836             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5837             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5838             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5839      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5840             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5841      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5842             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5843      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5844           enddo
5845         enddo
5846         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5847         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5848       enddo
5849       return
5850       end
5851 #endif
5852 c------------------------------------------------------------------------------
5853       subroutine eback_sc_corr(esccor)
5854 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5855 c        conformational states; temporarily implemented as differences
5856 c        between UNRES torsional potentials (dependent on three types of
5857 c        residues) and the torsional potentials dependent on all 20 types
5858 c        of residues computed from AM1  energy surfaces of terminally-blocked
5859 c        amino-acid residues.
5860       implicit real*8 (a-h,o-z)
5861       include 'DIMENSIONS'
5862       include 'COMMON.VAR'
5863       include 'COMMON.GEO'
5864       include 'COMMON.LOCAL'
5865       include 'COMMON.TORSION'
5866       include 'COMMON.SCCOR'
5867       include 'COMMON.INTERACT'
5868       include 'COMMON.DERIV'
5869       include 'COMMON.CHAIN'
5870       include 'COMMON.NAMES'
5871       include 'COMMON.IOUNITS'
5872       include 'COMMON.FFIELD'
5873       include 'COMMON.CONTROL'
5874       logical lprn
5875 C Set lprn=.true. for debugging
5876       lprn=.false.
5877 c      lprn=.true.
5878 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5879       esccor=0.0D0
5880       do i=iphi_start,iphi_end
5881         esccor_ii=0.0D0
5882         itori=itype(i-2)
5883         itori1=itype(i-1)
5884         phii=phi(i)
5885         gloci=0.0D0
5886         do j=1,nterm_sccor
5887           v1ij=v1sccor(j,itori,itori1)
5888           v2ij=v2sccor(j,itori,itori1)
5889           cosphi=dcos(j*phii)
5890           sinphi=dsin(j*phii)
5891           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5892           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5893         enddo
5894         if (lprn)
5895      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5896      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5897      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5898         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5899       enddo
5900       return
5901       end
5902 c----------------------------------------------------------------------------
5903       subroutine multibody(ecorr)
5904 C This subroutine calculates multi-body contributions to energy following
5905 C the idea of Skolnick et al. If side chains I and J make a contact and
5906 C at the same time side chains I+1 and J+1 make a contact, an extra
5907 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5908       implicit real*8 (a-h,o-z)
5909       include 'DIMENSIONS'
5910       include 'COMMON.IOUNITS'
5911       include 'COMMON.DERIV'
5912       include 'COMMON.INTERACT'
5913       include 'COMMON.CONTACTS'
5914 #ifdef MOMENT
5915       include 'COMMON.CONTACTS.MOMENT'
5916 #endif
5917       double precision gx(3),gx1(3)
5918       logical lprn
5919
5920 C Set lprn=.true. for debugging
5921       lprn=.false.
5922
5923       if (lprn) then
5924         write (iout,'(a)') 'Contact function values:'
5925         do i=nnt,nct-2
5926           write (iout,'(i2,20(1x,i2,f10.5))')
5927      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5928         enddo
5929       endif
5930       ecorr=0.0D0
5931       do i=nnt,nct
5932         do j=1,3
5933           gradcorr(j,i)=0.0D0
5934           gradxorr(j,i)=0.0D0
5935         enddo
5936       enddo
5937       do i=nnt,nct-2
5938
5939         DO ISHIFT = 3,4
5940
5941         i1=i+ishift
5942         num_conti=num_cont(i)
5943         num_conti1=num_cont(i1)
5944         do jj=1,num_conti
5945           j=jcont(jj,i)
5946           do kk=1,num_conti1
5947             j1=jcont(kk,i1)
5948             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5949 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5950 cd   &                   ' ishift=',ishift
5951 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5952 C The system gains extra energy.
5953               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5954             endif   ! j1==j+-ishift
5955           enddo     ! kk
5956         enddo       ! jj
5957
5958         ENDDO ! ISHIFT
5959
5960       enddo         ! i
5961       return
5962       end
5963 c------------------------------------------------------------------------------
5964       double precision function esccorr(i,j,k,l,jj,kk)
5965       implicit real*8 (a-h,o-z)
5966       include 'DIMENSIONS'
5967       include 'COMMON.IOUNITS'
5968       include 'COMMON.DERIV'
5969       include 'COMMON.INTERACT'
5970       include 'COMMON.CONTACTS'
5971 #ifdef MOMENT
5972       include 'COMMON.CONTACTS.MOMENT'
5973 #endif
5974       double precision gx(3),gx1(3)
5975       logical lprn
5976       lprn=.false.
5977       eij=facont(jj,i)
5978       ekl=facont(kk,k)
5979 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5980 C Calculate the multi-body contribution to energy.
5981 C Calculate multi-body contributions to the gradient.
5982 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5983 cd   & k,l,(gacont(m,kk,k),m=1,3)
5984       do m=1,3
5985         gx(m) =ekl*gacont(m,jj,i)
5986         gx1(m)=eij*gacont(m,kk,k)
5987         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5988         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5989         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5990         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5991       enddo
5992       do m=i,j-1
5993         do ll=1,3
5994           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5995         enddo
5996       enddo
5997       do m=k,l-1
5998         do ll=1,3
5999           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6000         enddo
6001       enddo
6002       esccorr=-eij*ekl
6003       return
6004       end
6005 c------------------------------------------------------------------------------
6006       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6007 C This subroutine calculates multi-body contributions to hydrogen-bonding
6008       implicit real*8 (a-h,o-z)
6009       include 'DIMENSIONS'
6010       include 'COMMON.IOUNITS'
6011 #ifdef MPI
6012       include "mpif.h"
6013       parameter (max_cont=maxconts)
6014       parameter (max_dim=26)
6015       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6016       double precision zapas(max_dim,maxconts,max_fg_procs),
6017      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6018       common /przechowalnia/ zapas
6019       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6020      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6021 #endif
6022       include 'COMMON.SETUP'
6023       include 'COMMON.FFIELD'
6024       include 'COMMON.DERIV'
6025       include 'COMMON.INTERACT'
6026       include 'COMMON.CONTACTS'
6027 #ifdef MOMENT
6028       include 'COMMON.CONTACTS.MOMENT'
6029 #endif
6030       include 'COMMON.CONTROL'
6031       include 'COMMON.LOCAL'
6032       double precision gx(3),gx1(3),time00
6033       logical lprn,ldone
6034
6035 C Set lprn=.true. for debugging
6036       lprn=.false.
6037 #ifdef MPI
6038       n_corr=0
6039       n_corr1=0
6040       if (nfgtasks.le.1) goto 30
6041       if (lprn) then
6042         write (iout,'(a)') 'Contact function values before RECEIVE:'
6043         do i=nnt,nct-2
6044           write (iout,'(2i3,50(1x,i2,f5.2))')
6045      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6046      &    j=1,num_cont_hb(i))
6047         enddo
6048       endif
6049       call flush(iout)
6050       do i=1,ntask_cont_from
6051         ncont_recv(i)=0
6052       enddo
6053       do i=1,ntask_cont_to
6054         ncont_sent(i)=0
6055       enddo
6056 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6057 c     & ntask_cont_to
6058 C Make the list of contacts to send to send to other procesors
6059 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6060 c      call flush(iout)
6061       do i=iturn3_start,iturn3_end
6062 c        write (iout,*) "make contact list turn3",i," num_cont",
6063 c     &    num_cont_hb(i)
6064         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6065       enddo
6066       do i=iturn4_start,iturn4_end
6067 c        write (iout,*) "make contact list turn4",i," num_cont",
6068 c     &   num_cont_hb(i)
6069         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6070       enddo
6071       do ii=1,nat_sent
6072         i=iat_sent(ii)
6073 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6074 c     &    num_cont_hb(i)
6075         do j=1,num_cont_hb(i)
6076         do k=1,4
6077           jjc=jcont_hb(j,i)
6078           iproc=iint_sent_local(k,jjc,ii)
6079 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6080           if (iproc.gt.0) then
6081             ncont_sent(iproc)=ncont_sent(iproc)+1
6082             nn=ncont_sent(iproc)
6083             zapas(1,nn,iproc)=i
6084             zapas(2,nn,iproc)=jjc
6085             zapas(3,nn,iproc)=facont_hb(j,i)
6086             zapas(4,nn,iproc)=ees0p(j,i)
6087             zapas(5,nn,iproc)=ees0m(j,i)
6088             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6089             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6090             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6091             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6092             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6093             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6094             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6095             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6096             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6097             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6098             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6099             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6100             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6101             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6102             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6103             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6104             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6105             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6106             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6107             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6108             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6109           endif
6110         enddo
6111         enddo
6112       enddo
6113       if (lprn) then
6114       write (iout,*)
6115      &  "Numbers of contacts to be sent to other processors",
6116      &  (ncont_sent(i),i=1,ntask_cont_to)
6117       write (iout,*) "Contacts sent"
6118       do ii=1,ntask_cont_to
6119         nn=ncont_sent(ii)
6120         iproc=itask_cont_to(ii)
6121         write (iout,*) nn," contacts to processor",iproc,
6122      &   " of CONT_TO_COMM group"
6123         do i=1,nn
6124           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6125         enddo
6126       enddo
6127       call flush(iout)
6128       endif
6129       CorrelType=477
6130       CorrelID=fg_rank+1
6131       CorrelType1=478
6132       CorrelID1=nfgtasks+fg_rank+1
6133       ireq=0
6134 C Receive the numbers of needed contacts from other processors
6135       do ii=1,ntask_cont_from
6136         iproc=itask_cont_from(ii)
6137         ireq=ireq+1
6138         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6139      &    FG_COMM,req(ireq),IERR)
6140       enddo
6141 c      write (iout,*) "IRECV ended"
6142 c      call flush(iout)
6143 C Send the number of contacts needed by other processors
6144       do ii=1,ntask_cont_to
6145         iproc=itask_cont_to(ii)
6146         ireq=ireq+1
6147         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6148      &    FG_COMM,req(ireq),IERR)
6149       enddo
6150 c      write (iout,*) "ISEND ended"
6151 c      write (iout,*) "number of requests (nn)",ireq
6152       call flush(iout)
6153       if (ireq.gt.0)
6154      &  call MPI_Waitall(ireq,req,status_array,ierr)
6155 c      write (iout,*)
6156 c     &  "Numbers of contacts to be received from other processors",
6157 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6158 c      call flush(iout)
6159 C Receive contacts
6160       ireq=0
6161       do ii=1,ntask_cont_from
6162         iproc=itask_cont_from(ii)
6163         nn=ncont_recv(ii)
6164 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6165 c     &   " of CONT_TO_COMM group"
6166         call flush(iout)
6167         if (nn.gt.0) then
6168           ireq=ireq+1
6169           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6170      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6171 c          write (iout,*) "ireq,req",ireq,req(ireq)
6172         endif
6173       enddo
6174 C Send the contacts to processors that need them
6175       do ii=1,ntask_cont_to
6176         iproc=itask_cont_to(ii)
6177         nn=ncont_sent(ii)
6178 c        write (iout,*) nn," contacts to processor",iproc,
6179 c     &   " of CONT_TO_COMM group"
6180         if (nn.gt.0) then
6181           ireq=ireq+1
6182           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6183      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6184 c          write (iout,*) "ireq,req",ireq,req(ireq)
6185 c          do i=1,nn
6186 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6187 c          enddo
6188         endif
6189       enddo
6190 c      write (iout,*) "number of requests (contacts)",ireq
6191 c      write (iout,*) "req",(req(i),i=1,4)
6192 c      call flush(iout)
6193       if (ireq.gt.0)
6194      & call MPI_Waitall(ireq,req,status_array,ierr)
6195       do iii=1,ntask_cont_from
6196         iproc=itask_cont_from(iii)
6197         nn=ncont_recv(iii)
6198         if (lprn) then
6199         write (iout,*) "Received",nn," contacts from processor",iproc,
6200      &   " of CONT_FROM_COMM group"
6201         call flush(iout)
6202         do i=1,nn
6203           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6204         enddo
6205         call flush(iout)
6206         endif
6207         do i=1,nn
6208           ii=zapas_recv(1,i,iii)
6209 c Flag the received contacts to prevent double-counting
6210           jj=-zapas_recv(2,i,iii)
6211 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6212 c          call flush(iout)
6213           nnn=num_cont_hb(ii)+1
6214           num_cont_hb(ii)=nnn
6215           jcont_hb(nnn,ii)=jj
6216           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6217           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6218           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6219           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6220           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6221           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6222           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6223           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6224           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6225           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6226           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6227           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6228           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6229           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6230           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6231           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6232           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6233           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6234           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6235           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6236           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6237           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6238           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6239           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6240         enddo
6241       enddo
6242       call flush(iout)
6243       if (lprn) then
6244         write (iout,'(a)') 'Contact function values after receive:'
6245         do i=nnt,nct-2
6246           write (iout,'(2i3,50(1x,i3,f5.2))')
6247      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6248      &    j=1,num_cont_hb(i))
6249         enddo
6250         call flush(iout)
6251       endif
6252    30 continue
6253 #endif
6254       if (lprn) then
6255         write (iout,'(a)') 'Contact function values:'
6256         do i=nnt,nct-2
6257           write (iout,'(2i3,50(1x,i3,f5.2))')
6258      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6259      &    j=1,num_cont_hb(i))
6260         enddo
6261       endif
6262       ecorr=0.0D0
6263 C Remove the loop below after debugging !!!
6264       do i=nnt,nct
6265         do j=1,3
6266           gradcorr(j,i)=0.0D0
6267           gradxorr(j,i)=0.0D0
6268         enddo
6269       enddo
6270 C Calculate the local-electrostatic correlation terms
6271       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6272         i1=i+1
6273         num_conti=num_cont_hb(i)
6274         num_conti1=num_cont_hb(i+1)
6275         do jj=1,num_conti
6276           j=jcont_hb(jj,i)
6277           jp=iabs(j)
6278           do kk=1,num_conti1
6279             j1=jcont_hb(kk,i1)
6280             jp1=iabs(j1)
6281 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6282 c     &         ' jj=',jj,' kk=',kk
6283             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6284      &          .or. j.lt.0 .and. j1.gt.0) .and.
6285      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6286 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6287 C The system gains extra energy.
6288               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6289               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6290      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6291               n_corr=n_corr+1
6292             else if (j1.eq.j) then
6293 C Contacts I-J and I-(J+1) occur simultaneously.
6294 C The system loses extra energy.
6295 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6296             endif
6297           enddo ! kk
6298           do kk=1,num_conti
6299             j1=jcont_hb(kk,i)
6300 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6301 c    &         ' jj=',jj,' kk=',kk
6302             if (j1.eq.j+1) then
6303 C Contacts I-J and (I+1)-J occur simultaneously.
6304 C The system loses extra energy.
6305 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6306             endif ! j1==j+1
6307           enddo ! kk
6308         enddo ! jj
6309       enddo ! i
6310       return
6311       end
6312 c------------------------------------------------------------------------------
6313       subroutine add_hb_contact(ii,jj,itask)
6314       implicit real*8 (a-h,o-z)
6315       include "DIMENSIONS"
6316       include "COMMON.IOUNITS"
6317       integer max_cont
6318       integer max_dim
6319       parameter (max_cont=maxconts)
6320       parameter (max_dim=26)
6321       include "COMMON.CONTACTS"
6322 #ifdef MOMENT
6323       include 'COMMON.CONTACTS.MOMENT'
6324 #endif
6325       double precision zapas(max_dim,maxconts,max_fg_procs),
6326      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6327       common /przechowalnia/ zapas
6328       integer i,j,ii,jj,iproc,itask(4),nn
6329 c      write (iout,*) "itask",itask
6330       do i=1,2
6331         iproc=itask(i)
6332         if (iproc.gt.0) then
6333           do j=1,num_cont_hb(ii)
6334             jjc=jcont_hb(j,ii)
6335 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6336             if (jjc.eq.jj) then
6337               ncont_sent(iproc)=ncont_sent(iproc)+1
6338               nn=ncont_sent(iproc)
6339               zapas(1,nn,iproc)=ii
6340               zapas(2,nn,iproc)=jjc
6341               zapas(3,nn,iproc)=facont_hb(j,ii)
6342               zapas(4,nn,iproc)=ees0p(j,ii)
6343               zapas(5,nn,iproc)=ees0m(j,ii)
6344               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6345               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6346               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6347               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6348               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6349               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6350               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6351               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6352               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6353               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6354               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6355               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6356               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6357               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6358               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6359               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6360               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6361               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6362               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6363               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6364               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6365               exit
6366             endif
6367           enddo
6368         endif
6369       enddo
6370       return
6371       end
6372 c------------------------------------------------------------------------------
6373       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6374      &  n_corr1)
6375 C This subroutine calculates multi-body contributions to hydrogen-bonding
6376       implicit real*8 (a-h,o-z)
6377       include 'DIMENSIONS'
6378       include 'COMMON.IOUNITS'
6379 #ifdef MPI
6380       include "mpif.h"
6381       parameter (max_cont=maxconts)
6382       parameter (max_dim=70)
6383       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6384       double precision zapas(max_dim,maxconts,max_fg_procs),
6385      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6386       common /przechowalnia/ zapas
6387       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6388      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6389 #endif
6390       include 'COMMON.SETUP'
6391       include 'COMMON.FFIELD'
6392       include 'COMMON.DERIV'
6393       include 'COMMON.LOCAL'
6394       include 'COMMON.INTERACT'
6395       include 'COMMON.CONTACTS'
6396 #ifdef MOMENT
6397       include 'COMMON.CONTACTS.MOMENT'
6398 #endif
6399       include 'COMMON.CHAIN'
6400       include 'COMMON.CONTROL'
6401       double precision gx(3),gx1(3)
6402       integer num_cont_hb_old(maxres)
6403       logical lprn,ldone
6404       double precision eello4,eello5,eelo6,eello_turn6
6405       external eello4,eello5,eello6,eello_turn6
6406 C Set lprn=.true. for debugging
6407       lprn=.false.
6408       eturn6=0.0d0
6409 #ifdef MPI
6410       do i=1,nres
6411         num_cont_hb_old(i)=num_cont_hb(i)
6412       enddo
6413       n_corr=0
6414       n_corr1=0
6415       if (nfgtasks.le.1) goto 30
6416       if (lprn) then
6417         write (iout,'(a)') 'Contact function values before RECEIVE:'
6418         do i=nnt,nct-2
6419           write (iout,'(2i3,50(1x,i2,f5.2))')
6420      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6421      &    j=1,num_cont_hb(i))
6422         enddo
6423       endif
6424       call flush(iout)
6425       do i=1,ntask_cont_from
6426         ncont_recv(i)=0
6427       enddo
6428       do i=1,ntask_cont_to
6429         ncont_sent(i)=0
6430       enddo
6431 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6432 c     & ntask_cont_to
6433 C Make the list of contacts to send to send to other procesors
6434       do i=iturn3_start,iturn3_end
6435 c        write (iout,*) "make contact list turn3",i," num_cont",
6436 c     &    num_cont_hb(i)
6437         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6438       enddo
6439       do i=iturn4_start,iturn4_end
6440 c        write (iout,*) "make contact list turn4",i," num_cont",
6441 c     &   num_cont_hb(i)
6442         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6443       enddo
6444       do ii=1,nat_sent
6445         i=iat_sent(ii)
6446 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6447 c     &    num_cont_hb(i)
6448         do j=1,num_cont_hb(i)
6449         do k=1,4
6450           jjc=jcont_hb(j,i)
6451           iproc=iint_sent_local(k,jjc,ii)
6452 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6453           if (iproc.ne.0) then
6454             ncont_sent(iproc)=ncont_sent(iproc)+1
6455             nn=ncont_sent(iproc)
6456             zapas(1,nn,iproc)=i
6457             zapas(2,nn,iproc)=jjc
6458             zapas(3,nn,iproc)=d_cont(j,i)
6459             ind=3
6460             do kk=1,3
6461               ind=ind+1
6462               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6463             enddo
6464             do kk=1,2
6465               do ll=1,2
6466                 ind=ind+1
6467                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6468               enddo
6469             enddo
6470             do jj=1,5
6471               do kk=1,3
6472                 do ll=1,2
6473                   do mm=1,2
6474                     ind=ind+1
6475                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6476                   enddo
6477                 enddo
6478               enddo
6479             enddo
6480           endif
6481         enddo
6482         enddo
6483       enddo
6484       if (lprn) then
6485       write (iout,*)
6486      &  "Numbers of contacts to be sent to other processors",
6487      &  (ncont_sent(i),i=1,ntask_cont_to)
6488       write (iout,*) "Contacts sent"
6489       do ii=1,ntask_cont_to
6490         nn=ncont_sent(ii)
6491         iproc=itask_cont_to(ii)
6492         write (iout,*) nn," contacts to processor",iproc,
6493      &   " of CONT_TO_COMM group"
6494         do i=1,nn
6495           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6496         enddo
6497       enddo
6498       call flush(iout)
6499       endif
6500       CorrelType=477
6501       CorrelID=fg_rank+1
6502       CorrelType1=478
6503       CorrelID1=nfgtasks+fg_rank+1
6504       ireq=0
6505 C Receive the numbers of needed contacts from other processors
6506       do ii=1,ntask_cont_from
6507         iproc=itask_cont_from(ii)
6508         ireq=ireq+1
6509         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6510      &    FG_COMM,req(ireq),IERR)
6511       enddo
6512 c      write (iout,*) "IRECV ended"
6513 c      call flush(iout)
6514 C Send the number of contacts needed by other processors
6515       do ii=1,ntask_cont_to
6516         iproc=itask_cont_to(ii)
6517         ireq=ireq+1
6518         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6519      &    FG_COMM,req(ireq),IERR)
6520       enddo
6521 c      write (iout,*) "ISEND ended"
6522 c      write (iout,*) "number of requests (nn)",ireq
6523       call flush(iout)
6524       if (ireq.gt.0)
6525      &  call MPI_Waitall(ireq,req,status_array,ierr)
6526 c      write (iout,*)
6527 c     &  "Numbers of contacts to be received from other processors",
6528 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6529 c      call flush(iout)
6530 C Receive contacts
6531       ireq=0
6532       do ii=1,ntask_cont_from
6533         iproc=itask_cont_from(ii)
6534         nn=ncont_recv(ii)
6535 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6536 c     &   " of CONT_TO_COMM group"
6537         call flush(iout)
6538         if (nn.gt.0) then
6539           ireq=ireq+1
6540           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6541      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6542 c          write (iout,*) "ireq,req",ireq,req(ireq)
6543         endif
6544       enddo
6545 C Send the contacts to processors that need them
6546       do ii=1,ntask_cont_to
6547         iproc=itask_cont_to(ii)
6548         nn=ncont_sent(ii)
6549 c        write (iout,*) nn," contacts to processor",iproc,
6550 c     &   " of CONT_TO_COMM group"
6551         if (nn.gt.0) then
6552           ireq=ireq+1
6553           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6554      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6555 c          write (iout,*) "ireq,req",ireq,req(ireq)
6556 c          do i=1,nn
6557 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6558 c          enddo
6559         endif
6560       enddo
6561 c      write (iout,*) "number of requests (contacts)",ireq
6562 c      write (iout,*) "req",(req(i),i=1,4)
6563 c      call flush(iout)
6564       if (ireq.gt.0)
6565      & call MPI_Waitall(ireq,req,status_array,ierr)
6566       do iii=1,ntask_cont_from
6567         iproc=itask_cont_from(iii)
6568         nn=ncont_recv(iii)
6569         if (lprn) then
6570         write (iout,*) "Received",nn," contacts from processor",iproc,
6571      &   " of CONT_FROM_COMM group"
6572         call flush(iout)
6573         do i=1,nn
6574           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6575         enddo
6576         call flush(iout)
6577         endif
6578         do i=1,nn
6579           ii=zapas_recv(1,i,iii)
6580 c Flag the received contacts to prevent double-counting
6581           jj=-zapas_recv(2,i,iii)
6582 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6583 c          call flush(iout)
6584           nnn=num_cont_hb(ii)+1
6585           num_cont_hb(ii)=nnn
6586           jcont_hb(nnn,ii)=jj
6587           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6588           ind=3
6589           do kk=1,3
6590             ind=ind+1
6591             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6592           enddo
6593           do kk=1,2
6594             do ll=1,2
6595               ind=ind+1
6596               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6597             enddo
6598           enddo
6599           do jj=1,5
6600             do kk=1,3
6601               do ll=1,2
6602                 do mm=1,2
6603                   ind=ind+1
6604                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6605                 enddo
6606               enddo
6607             enddo
6608           enddo
6609         enddo
6610       enddo
6611       call flush(iout)
6612       if (lprn) then
6613         write (iout,'(a)') 'Contact function values after receive:'
6614         do i=nnt,nct-2
6615           write (iout,'(2i3,50(1x,i3,5f6.3))')
6616      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6617      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6618         enddo
6619         call flush(iout)
6620       endif
6621    30 continue
6622 #endif
6623       if (lprn) then
6624         write (iout,'(a)') 'Contact function values:'
6625         do i=nnt,nct-2
6626           write (iout,'(2i3,50(1x,i2,5f6.3))')
6627      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6628      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6629         enddo
6630       endif
6631       ecorr=0.0D0
6632       ecorr5=0.0d0
6633       ecorr6=0.0d0
6634 C Remove the loop below after debugging !!!
6635       do i=nnt,nct
6636         do j=1,3
6637           gradcorr(j,i)=0.0D0
6638           gradxorr(j,i)=0.0D0
6639         enddo
6640       enddo
6641 C Calculate the dipole-dipole interaction energies
6642       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6643       do i=iatel_s,iatel_e+1
6644         num_conti=num_cont_hb(i)
6645         do jj=1,num_conti
6646           j=jcont_hb(jj,i)
6647 #ifdef MOMENT
6648           call dipole(i,j,jj)
6649 #endif
6650         enddo
6651       enddo
6652       endif
6653 C Calculate the local-electrostatic correlation terms
6654 c                write (iout,*) "gradcorr5 in eello5 before loop"
6655 c                do iii=1,nres
6656 c                  write (iout,'(i5,3f10.5)')
6657 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6658 c                enddo
6659       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6660 c        write (iout,*) "corr loop i",i
6661         i1=i+1
6662         num_conti=num_cont_hb(i)
6663         num_conti1=num_cont_hb(i+1)
6664         do jj=1,num_conti
6665           j=jcont_hb(jj,i)
6666           jp=iabs(j)
6667           do kk=1,num_conti1
6668             j1=jcont_hb(kk,i1)
6669             jp1=iabs(j1)
6670 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6671 c     &         ' jj=',jj,' kk=',kk
6672 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6673             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6674      &          .or. j.lt.0 .and. j1.gt.0) .and.
6675      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6676 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6677 C The system gains extra energy.
6678               n_corr=n_corr+1
6679               sqd1=dsqrt(d_cont(jj,i))
6680               sqd2=dsqrt(d_cont(kk,i1))
6681               sred_geom = sqd1*sqd2
6682               IF (sred_geom.lt.cutoff_corr) THEN
6683                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6684      &            ekont,fprimcont)
6685 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6686 cd     &         ' jj=',jj,' kk=',kk
6687                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6688                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6689                 do l=1,3
6690                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6691                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6692                 enddo
6693                 n_corr1=n_corr1+1
6694 cd               write (iout,*) 'sred_geom=',sred_geom,
6695 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6696 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6697 cd               write (iout,*) "g_contij",g_contij
6698 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6699 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6700                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6701                 if (wcorr4.gt.0.0d0)
6702      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6703                   if (energy_dec.and.wcorr4.gt.0.0d0)
6704      1                 write (iout,'(a6,4i5,0pf7.3)')
6705      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6706 c                write (iout,*) "gradcorr5 before eello5"
6707 c                do iii=1,nres
6708 c                  write (iout,'(i5,3f10.5)')
6709 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6710 c                enddo
6711                 if (wcorr5.gt.0.0d0)
6712      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6713 c                write (iout,*) "gradcorr5 after eello5"
6714 c                do iii=1,nres
6715 c                  write (iout,'(i5,3f10.5)')
6716 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6717 c                enddo
6718                   if (energy_dec.and.wcorr5.gt.0.0d0)
6719      1                 write (iout,'(a6,4i5,0pf7.3)')
6720      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6721 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6722 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6723                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6724      &               .or. wturn6.eq.0.0d0))then
6725 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6726                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6727                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6728      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6729 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6730 cd     &            'ecorr6=',ecorr6
6731 cd                write (iout,'(4e15.5)') sred_geom,
6732 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6733 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6734 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6735                 else if (wturn6.gt.0.0d0
6736      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6737 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6738                   eturn6=eturn6+eello_turn6(i,jj,kk)
6739                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6740      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6741 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6742                 endif
6743               ENDIF
6744 1111          continue
6745             endif
6746           enddo ! kk
6747         enddo ! jj
6748       enddo ! i
6749       do i=1,nres
6750         num_cont_hb(i)=num_cont_hb_old(i)
6751       enddo
6752 c                write (iout,*) "gradcorr5 in eello5"
6753 c                do iii=1,nres
6754 c                  write (iout,'(i5,3f10.5)')
6755 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6756 c                enddo
6757       return
6758       end
6759 c------------------------------------------------------------------------------
6760       subroutine add_hb_contact_eello(ii,jj,itask)
6761       implicit real*8 (a-h,o-z)
6762       include "DIMENSIONS"
6763       include "COMMON.IOUNITS"
6764       integer max_cont
6765       integer max_dim
6766       parameter (max_cont=maxconts)
6767       parameter (max_dim=70)
6768       include "COMMON.CONTACTS"
6769 #ifdef MOMENT
6770       include 'COMMON.CONTACTS.MOMENT'
6771 #endif
6772       double precision zapas(max_dim,maxconts,max_fg_procs),
6773      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6774       common /przechowalnia/ zapas
6775       integer i,j,ii,jj,iproc,itask(4),nn
6776 c      write (iout,*) "itask",itask
6777       do i=1,2
6778         iproc=itask(i)
6779         if (iproc.gt.0) then
6780           do j=1,num_cont_hb(ii)
6781             jjc=jcont_hb(j,ii)
6782 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6783             if (jjc.eq.jj) then
6784               ncont_sent(iproc)=ncont_sent(iproc)+1
6785               nn=ncont_sent(iproc)
6786               zapas(1,nn,iproc)=ii
6787               zapas(2,nn,iproc)=jjc
6788               zapas(3,nn,iproc)=d_cont(j,ii)
6789               ind=3
6790               do kk=1,3
6791                 ind=ind+1
6792                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6793               enddo
6794               do kk=1,2
6795                 do ll=1,2
6796                   ind=ind+1
6797                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6798                 enddo
6799               enddo
6800               do jj=1,5
6801                 do kk=1,3
6802                   do ll=1,2
6803                     do mm=1,2
6804                       ind=ind+1
6805                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6806                     enddo
6807                   enddo
6808                 enddo
6809               enddo
6810               exit
6811             endif
6812           enddo
6813         endif
6814       enddo
6815       return
6816       end
6817 c------------------------------------------------------------------------------
6818       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6819       implicit real*8 (a-h,o-z)
6820       include 'DIMENSIONS'
6821       include 'COMMON.IOUNITS'
6822       include 'COMMON.DERIV'
6823       include 'COMMON.INTERACT'
6824       include 'COMMON.CONTACTS'
6825 #ifdef MOMENT
6826       include 'COMMON.CONTACTS.MOMENT'
6827 #endif
6828       double precision gx(3),gx1(3)
6829       logical lprn
6830       lprn=.false.
6831       eij=facont_hb(jj,i)
6832       ekl=facont_hb(kk,k)
6833       ees0pij=ees0p(jj,i)
6834       ees0pkl=ees0p(kk,k)
6835       ees0mij=ees0m(jj,i)
6836       ees0mkl=ees0m(kk,k)
6837       ekont=eij*ekl
6838       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6839 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6840 C Following 4 lines for diagnostics.
6841 cd    ees0pkl=0.0D0
6842 cd    ees0pij=1.0D0
6843 cd    ees0mkl=0.0D0
6844 cd    ees0mij=1.0D0
6845 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6846 c     & 'Contacts ',i,j,
6847 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6848 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6849 c     & 'gradcorr_long'
6850 C Calculate the multi-body contribution to energy.
6851 c      ecorr=ecorr+ekont*ees
6852 C Calculate multi-body contributions to the gradient.
6853       coeffpees0pij=coeffp*ees0pij
6854       coeffmees0mij=coeffm*ees0mij
6855       coeffpees0pkl=coeffp*ees0pkl
6856       coeffmees0mkl=coeffm*ees0mkl
6857       do ll=1,3
6858 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6859         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6860      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6861      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6862         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6863      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6864      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6865 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6866         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6867      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6868      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6869         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6870      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6871      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6872         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6873      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6874      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6875         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6876         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6877         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6878      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6879      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6880         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6881         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6882 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6883       enddo
6884 c      write (iout,*)
6885 cgrad      do m=i+1,j-1
6886 cgrad        do ll=1,3
6887 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6888 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6889 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6890 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6891 cgrad        enddo
6892 cgrad      enddo
6893 cgrad      do m=k+1,l-1
6894 cgrad        do ll=1,3
6895 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6896 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6897 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6898 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6899 cgrad        enddo
6900 cgrad      enddo
6901 c      write (iout,*) "ehbcorr",ekont*ees
6902       ehbcorr=ekont*ees
6903       return
6904       end
6905 #ifdef MOMENT
6906 C---------------------------------------------------------------------------
6907       subroutine dipole(i,j,jj)
6908       implicit real*8 (a-h,o-z)
6909       include 'DIMENSIONS'
6910       include 'COMMON.IOUNITS'
6911       include 'COMMON.CHAIN'
6912       include 'COMMON.FFIELD'
6913       include 'COMMON.DERIV'
6914       include 'COMMON.INTERACT'
6915       include 'COMMON.CONTACTS'
6916 #ifdef MOMENT
6917       include 'COMMON.CONTACTS.MOMENT'
6918 #endif
6919       include 'COMMON.TORSION'
6920       include 'COMMON.VAR'
6921       include 'COMMON.GEO'
6922       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6923      &  auxmat(2,2)
6924       iti1 = itortyp(itype(i+1))
6925       if (j.lt.nres-1) then
6926         itj1 = itortyp(itype(j+1))
6927       else
6928         itj1=ntortyp+1
6929       endif
6930       do iii=1,2
6931         dipi(iii,1)=Ub2(iii,i)
6932         dipderi(iii)=Ub2der(iii,i)
6933         dipi(iii,2)=b1(iii,iti1)
6934         dipj(iii,1)=Ub2(iii,j)
6935         dipderj(iii)=Ub2der(iii,j)
6936         dipj(iii,2)=b1(iii,itj1)
6937       enddo
6938       kkk=0
6939       do iii=1,2
6940         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6941         do jjj=1,2
6942           kkk=kkk+1
6943           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6944         enddo
6945       enddo
6946       do kkk=1,5
6947         do lll=1,3
6948           mmm=0
6949           do iii=1,2
6950             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6951      &        auxvec(1))
6952             do jjj=1,2
6953               mmm=mmm+1
6954               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6955             enddo
6956           enddo
6957         enddo
6958       enddo
6959       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6960       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6961       do iii=1,2
6962         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6963       enddo
6964       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6965       do iii=1,2
6966         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6967       enddo
6968       return
6969       end
6970 #endif
6971 C---------------------------------------------------------------------------
6972       subroutine calc_eello(i,j,k,l,jj,kk)
6973 C
6974 C This subroutine computes matrices and vectors needed to calculate
6975 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6976 C
6977       implicit real*8 (a-h,o-z)
6978       include 'DIMENSIONS'
6979       include 'COMMON.IOUNITS'
6980       include 'COMMON.CHAIN'
6981       include 'COMMON.DERIV'
6982       include 'COMMON.INTERACT'
6983       include 'COMMON.CONTACTS'
6984 #ifdef MOMENT
6985       include 'COMMON.CONTACTS.MOMENT'
6986 #endif
6987       include 'COMMON.TORSION'
6988       include 'COMMON.VAR'
6989       include 'COMMON.GEO'
6990       include 'COMMON.FFIELD'
6991       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6992      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6993       logical lprn
6994       common /kutas/ lprn
6995 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6996 cd     & ' jj=',jj,' kk=',kk
6997 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6998 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6999 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7000       do iii=1,2
7001         do jjj=1,2
7002           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7003           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7004         enddo
7005       enddo
7006       call transpose2(aa1(1,1),aa1t(1,1))
7007       call transpose2(aa2(1,1),aa2t(1,1))
7008       do kkk=1,5
7009         do lll=1,3
7010           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7011      &      aa1tder(1,1,lll,kkk))
7012           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7013      &      aa2tder(1,1,lll,kkk))
7014         enddo
7015       enddo
7016       if (l.eq.j+1) then
7017 C parallel orientation of the two CA-CA-CA frames.
7018         if (i.gt.1) then
7019           iti=itortyp(itype(i))
7020         else
7021           iti=ntortyp+1
7022         endif
7023         itk1=itortyp(itype(k+1))
7024         itj=itortyp(itype(j))
7025         if (l.lt.nres-1) then
7026           itl1=itortyp(itype(l+1))
7027         else
7028           itl1=ntortyp+1
7029         endif
7030 C A1 kernel(j+1) A2T
7031 cd        do iii=1,2
7032 cd          write (iout,'(3f10.5,5x,3f10.5)')
7033 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7034 cd        enddo
7035         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7036      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7037      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7038 C Following matrices are needed only for 6-th order cumulants
7039         IF (wcorr6.gt.0.0d0) THEN
7040         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7041      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7042      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7043         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7044      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7045      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7046      &   ADtEAderx(1,1,1,1,1,1))
7047         lprn=.false.
7048         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7049      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7050      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7051      &   ADtEA1derx(1,1,1,1,1,1))
7052         ENDIF
7053 C End 6-th order cumulants
7054 cd        lprn=.false.
7055 cd        if (lprn) then
7056 cd        write (2,*) 'In calc_eello6'
7057 cd        do iii=1,2
7058 cd          write (2,*) 'iii=',iii
7059 cd          do kkk=1,5
7060 cd            write (2,*) 'kkk=',kkk
7061 cd            do jjj=1,2
7062 cd              write (2,'(3(2f10.5),5x)')
7063 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7064 cd            enddo
7065 cd          enddo
7066 cd        enddo
7067 cd        endif
7068         call transpose2(EUgder(1,1,k),auxmat(1,1))
7069         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7070         call transpose2(EUg(1,1,k),auxmat(1,1))
7071         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7072         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7073         do iii=1,2
7074           do kkk=1,5
7075             do lll=1,3
7076               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7077      &          EAEAderx(1,1,lll,kkk,iii,1))
7078             enddo
7079           enddo
7080         enddo
7081 C A1T kernel(i+1) A2
7082         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7083      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7084      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7085 C Following matrices are needed only for 6-th order cumulants
7086         IF (wcorr6.gt.0.0d0) THEN
7087         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7088      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7089      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7090         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7091      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7092      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7093      &   ADtEAderx(1,1,1,1,1,2))
7094         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7095      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7096      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7097      &   ADtEA1derx(1,1,1,1,1,2))
7098         ENDIF
7099 C End 6-th order cumulants
7100         call transpose2(EUgder(1,1,l),auxmat(1,1))
7101         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7102         call transpose2(EUg(1,1,l),auxmat(1,1))
7103         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7104         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7105         do iii=1,2
7106           do kkk=1,5
7107             do lll=1,3
7108               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7109      &          EAEAderx(1,1,lll,kkk,iii,2))
7110             enddo
7111           enddo
7112         enddo
7113 C AEAb1 and AEAb2
7114 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7115 C They are needed only when the fifth- or the sixth-order cumulants are
7116 C indluded.
7117         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7118         call transpose2(AEA(1,1,1),auxmat(1,1))
7119         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7120         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7121         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7122         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7123         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7124         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7125         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7126         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7127         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7128         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7129         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7130         call transpose2(AEA(1,1,2),auxmat(1,1))
7131         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7132         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7133         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7134         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7135         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7136         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7137         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7138         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7139         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7140         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7141         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7142 C Calculate the Cartesian derivatives of the vectors.
7143         do iii=1,2
7144           do kkk=1,5
7145             do lll=1,3
7146               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7147               call matvec2(auxmat(1,1),b1(1,iti),
7148      &          AEAb1derx(1,lll,kkk,iii,1,1))
7149               call matvec2(auxmat(1,1),Ub2(1,i),
7150      &          AEAb2derx(1,lll,kkk,iii,1,1))
7151               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7152      &          AEAb1derx(1,lll,kkk,iii,2,1))
7153               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7154      &          AEAb2derx(1,lll,kkk,iii,2,1))
7155               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7156               call matvec2(auxmat(1,1),b1(1,itj),
7157      &          AEAb1derx(1,lll,kkk,iii,1,2))
7158               call matvec2(auxmat(1,1),Ub2(1,j),
7159      &          AEAb2derx(1,lll,kkk,iii,1,2))
7160               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7161      &          AEAb1derx(1,lll,kkk,iii,2,2))
7162               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7163      &          AEAb2derx(1,lll,kkk,iii,2,2))
7164             enddo
7165           enddo
7166         enddo
7167         ENDIF
7168 C End vectors
7169       else
7170 C Antiparallel orientation of the two CA-CA-CA frames.
7171         if (i.gt.1) then
7172           iti=itortyp(itype(i))
7173         else
7174           iti=ntortyp+1
7175         endif
7176         itk1=itortyp(itype(k+1))
7177         itl=itortyp(itype(l))
7178         itj=itortyp(itype(j))
7179         if (j.lt.nres-1) then
7180           itj1=itortyp(itype(j+1))
7181         else
7182           itj1=ntortyp+1
7183         endif
7184 C A2 kernel(j-1)T A1T
7185         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7186      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7187      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7188 C Following matrices are needed only for 6-th order cumulants
7189         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7190      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7191         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7192      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7193      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7194         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7195      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7196      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7197      &   ADtEAderx(1,1,1,1,1,1))
7198         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7199      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7200      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7201      &   ADtEA1derx(1,1,1,1,1,1))
7202         ENDIF
7203 C End 6-th order cumulants
7204         call transpose2(EUgder(1,1,k),auxmat(1,1))
7205         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7206         call transpose2(EUg(1,1,k),auxmat(1,1))
7207         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7208         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7209         do iii=1,2
7210           do kkk=1,5
7211             do lll=1,3
7212               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7213      &          EAEAderx(1,1,lll,kkk,iii,1))
7214             enddo
7215           enddo
7216         enddo
7217 C A2T kernel(i+1)T A1
7218         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7219      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7220      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7221 C Following matrices are needed only for 6-th order cumulants
7222         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7223      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7224         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7225      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7226      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7227         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7228      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7229      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7230      &   ADtEAderx(1,1,1,1,1,2))
7231         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7232      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7233      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7234      &   ADtEA1derx(1,1,1,1,1,2))
7235         ENDIF
7236 C End 6-th order cumulants
7237         call transpose2(EUgder(1,1,j),auxmat(1,1))
7238         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7239         call transpose2(EUg(1,1,j),auxmat(1,1))
7240         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7241         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7242         do iii=1,2
7243           do kkk=1,5
7244             do lll=1,3
7245               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7246      &          EAEAderx(1,1,lll,kkk,iii,2))
7247             enddo
7248           enddo
7249         enddo
7250 C AEAb1 and AEAb2
7251 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7252 C They are needed only when the fifth- or the sixth-order cumulants are
7253 C indluded.
7254         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7255      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7256         call transpose2(AEA(1,1,1),auxmat(1,1))
7257         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7258         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7259         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7260         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7261         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7262         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7263         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7264         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7265         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7266         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7267         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7268         call transpose2(AEA(1,1,2),auxmat(1,1))
7269         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7270         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7271         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7272         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7273         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7274         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7275         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7276         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7277         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7278         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7279         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7280 C Calculate the Cartesian derivatives of the vectors.
7281         do iii=1,2
7282           do kkk=1,5
7283             do lll=1,3
7284               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7285               call matvec2(auxmat(1,1),b1(1,iti),
7286      &          AEAb1derx(1,lll,kkk,iii,1,1))
7287               call matvec2(auxmat(1,1),Ub2(1,i),
7288      &          AEAb2derx(1,lll,kkk,iii,1,1))
7289               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7290      &          AEAb1derx(1,lll,kkk,iii,2,1))
7291               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7292      &          AEAb2derx(1,lll,kkk,iii,2,1))
7293               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7294               call matvec2(auxmat(1,1),b1(1,itl),
7295      &          AEAb1derx(1,lll,kkk,iii,1,2))
7296               call matvec2(auxmat(1,1),Ub2(1,l),
7297      &          AEAb2derx(1,lll,kkk,iii,1,2))
7298               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7299      &          AEAb1derx(1,lll,kkk,iii,2,2))
7300               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7301      &          AEAb2derx(1,lll,kkk,iii,2,2))
7302             enddo
7303           enddo
7304         enddo
7305         ENDIF
7306 C End vectors
7307       endif
7308       return
7309       end
7310 C---------------------------------------------------------------------------
7311       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7312      &  KK,KKderg,AKA,AKAderg,AKAderx)
7313       implicit none
7314       integer nderg
7315       logical transp
7316       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7317      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7318      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7319       integer iii,kkk,lll
7320       integer jjj,mmm
7321       logical lprn
7322       common /kutas/ lprn
7323       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7324       do iii=1,nderg
7325         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7326      &    AKAderg(1,1,iii))
7327       enddo
7328 cd      if (lprn) write (2,*) 'In kernel'
7329       do kkk=1,5
7330 cd        if (lprn) write (2,*) 'kkk=',kkk
7331         do lll=1,3
7332           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7333      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7334 cd          if (lprn) then
7335 cd            write (2,*) 'lll=',lll
7336 cd            write (2,*) 'iii=1'
7337 cd            do jjj=1,2
7338 cd              write (2,'(3(2f10.5),5x)')
7339 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7340 cd            enddo
7341 cd          endif
7342           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7343      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7344 cd          if (lprn) then
7345 cd            write (2,*) 'lll=',lll
7346 cd            write (2,*) 'iii=2'
7347 cd            do jjj=1,2
7348 cd              write (2,'(3(2f10.5),5x)')
7349 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7350 cd            enddo
7351 cd          endif
7352         enddo
7353       enddo
7354       return
7355       end
7356 C---------------------------------------------------------------------------
7357       double precision function eello4(i,j,k,l,jj,kk)
7358       implicit real*8 (a-h,o-z)
7359       include 'DIMENSIONS'
7360       include 'COMMON.IOUNITS'
7361       include 'COMMON.CHAIN'
7362       include 'COMMON.DERIV'
7363       include 'COMMON.INTERACT'
7364       include 'COMMON.CONTACTS'
7365 #ifdef MOMENT
7366       include 'COMMON.CONTACTS.MOMENT'
7367 #endif
7368       include 'COMMON.TORSION'
7369       include 'COMMON.VAR'
7370       include 'COMMON.GEO'
7371       double precision pizda(2,2),ggg1(3),ggg2(3)
7372 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7373 cd        eello4=0.0d0
7374 cd        return
7375 cd      endif
7376 cd      print *,'eello4:',i,j,k,l,jj,kk
7377 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7378 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7379 cold      eij=facont_hb(jj,i)
7380 cold      ekl=facont_hb(kk,k)
7381 cold      ekont=eij*ekl
7382       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7383 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7384       gcorr_loc(k-1)=gcorr_loc(k-1)
7385      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7386       if (l.eq.j+1) then
7387         gcorr_loc(l-1)=gcorr_loc(l-1)
7388      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7389       else
7390         gcorr_loc(j-1)=gcorr_loc(j-1)
7391      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7392       endif
7393       do iii=1,2
7394         do kkk=1,5
7395           do lll=1,3
7396             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7397      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7398 cd            derx(lll,kkk,iii)=0.0d0
7399           enddo
7400         enddo
7401       enddo
7402 cd      gcorr_loc(l-1)=0.0d0
7403 cd      gcorr_loc(j-1)=0.0d0
7404 cd      gcorr_loc(k-1)=0.0d0
7405 cd      eel4=1.0d0
7406 cd      write (iout,*)'Contacts have occurred for peptide groups',
7407 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7408 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7409       if (j.lt.nres-1) then
7410         j1=j+1
7411         j2=j-1
7412       else
7413         j1=j-1
7414         j2=j-2
7415       endif
7416       if (l.lt.nres-1) then
7417         l1=l+1
7418         l2=l-1
7419       else
7420         l1=l-1
7421         l2=l-2
7422       endif
7423       do ll=1,3
7424 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7425 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7426         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7427         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7428 cgrad        ghalf=0.5d0*ggg1(ll)
7429         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7430         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7431         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7432         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7433         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7434         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7435 cgrad        ghalf=0.5d0*ggg2(ll)
7436         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7437         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7438         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7439         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7440         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7441         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7442       enddo
7443 cgrad      do m=i+1,j-1
7444 cgrad        do ll=1,3
7445 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7446 cgrad        enddo
7447 cgrad      enddo
7448 cgrad      do m=k+1,l-1
7449 cgrad        do ll=1,3
7450 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7451 cgrad        enddo
7452 cgrad      enddo
7453 cgrad      do m=i+2,j2
7454 cgrad        do ll=1,3
7455 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7456 cgrad        enddo
7457 cgrad      enddo
7458 cgrad      do m=k+2,l2
7459 cgrad        do ll=1,3
7460 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7461 cgrad        enddo
7462 cgrad      enddo
7463 cd      do iii=1,nres-3
7464 cd        write (2,*) iii,gcorr_loc(iii)
7465 cd      enddo
7466       eello4=ekont*eel4
7467 cd      write (2,*) 'ekont',ekont
7468 cd      write (iout,*) 'eello4',ekont*eel4
7469       return
7470       end
7471 C---------------------------------------------------------------------------
7472       double precision function eello5(i,j,k,l,jj,kk)
7473       implicit real*8 (a-h,o-z)
7474       include 'DIMENSIONS'
7475       include 'COMMON.IOUNITS'
7476       include 'COMMON.CHAIN'
7477       include 'COMMON.DERIV'
7478       include 'COMMON.INTERACT'
7479       include 'COMMON.CONTACTS'
7480 #ifdef MOMENT
7481       include 'COMMON.CONTACTS.MOMENT'
7482 #endif
7483       include 'COMMON.TORSION'
7484       include 'COMMON.VAR'
7485       include 'COMMON.GEO'
7486       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7487       double precision ggg1(3),ggg2(3)
7488 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7489 C                                                                              C
7490 C                            Parallel chains                                   C
7491 C                                                                              C
7492 C          o             o                   o             o                   C
7493 C         /l\           / \             \   / \           / \   /              C
7494 C        /   \         /   \             \ /   \         /   \ /               C
7495 C       j| o |l1       | o |              o| o |         | o |o                C
7496 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7497 C      \i/   \         /   \ /             /   \         /   \                 C
7498 C       o    k1             o                                                  C
7499 C         (I)          (II)                (III)          (IV)                 C
7500 C                                                                              C
7501 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7502 C                                                                              C
7503 C                            Antiparallel chains                               C
7504 C                                                                              C
7505 C          o             o                   o             o                   C
7506 C         /j\           / \             \   / \           / \   /              C
7507 C        /   \         /   \             \ /   \         /   \ /               C
7508 C      j1| o |l        | o |              o| o |         | o |o                C
7509 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7510 C      \i/   \         /   \ /             /   \         /   \                 C
7511 C       o     k1            o                                                  C
7512 C         (I)          (II)                (III)          (IV)                 C
7513 C                                                                              C
7514 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7515 C                                                                              C
7516 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7517 C                                                                              C
7518 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7519 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7520 cd        eello5=0.0d0
7521 cd        return
7522 cd      endif
7523 cd      write (iout,*)
7524 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7525 cd     &   ' and',k,l
7526       itk=itortyp(itype(k))
7527       itl=itortyp(itype(l))
7528       itj=itortyp(itype(j))
7529       eello5_1=0.0d0
7530       eello5_2=0.0d0
7531       eello5_3=0.0d0
7532       eello5_4=0.0d0
7533 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7534 cd     &   eel5_3_num,eel5_4_num)
7535       do iii=1,2
7536         do kkk=1,5
7537           do lll=1,3
7538             derx(lll,kkk,iii)=0.0d0
7539           enddo
7540         enddo
7541       enddo
7542 cd      eij=facont_hb(jj,i)
7543 cd      ekl=facont_hb(kk,k)
7544 cd      ekont=eij*ekl
7545 cd      write (iout,*)'Contacts have occurred for peptide groups',
7546 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7547 cd      goto 1111
7548 C Contribution from the graph I.
7549 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7550 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7551       call transpose2(EUg(1,1,k),auxmat(1,1))
7552       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7553       vv(1)=pizda(1,1)-pizda(2,2)
7554       vv(2)=pizda(1,2)+pizda(2,1)
7555       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7556      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7557 C Explicit gradient in virtual-dihedral angles.
7558       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7559      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7560      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7561       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7562       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7563       vv(1)=pizda(1,1)-pizda(2,2)
7564       vv(2)=pizda(1,2)+pizda(2,1)
7565       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7566      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7567      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7568       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7569       vv(1)=pizda(1,1)-pizda(2,2)
7570       vv(2)=pizda(1,2)+pizda(2,1)
7571       if (l.eq.j+1) then
7572         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7573      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7574      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7575       else
7576         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7577      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7578      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7579       endif
7580 C Cartesian gradient
7581       do iii=1,2
7582         do kkk=1,5
7583           do lll=1,3
7584             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7585      &        pizda(1,1))
7586             vv(1)=pizda(1,1)-pizda(2,2)
7587             vv(2)=pizda(1,2)+pizda(2,1)
7588             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7589      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7590      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7591           enddo
7592         enddo
7593       enddo
7594 c      goto 1112
7595 c1111  continue
7596 C Contribution from graph II
7597       call transpose2(EE(1,1,itk),auxmat(1,1))
7598       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7599       vv(1)=pizda(1,1)+pizda(2,2)
7600       vv(2)=pizda(2,1)-pizda(1,2)
7601       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7602      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7603 C Explicit gradient in virtual-dihedral angles.
7604       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7605      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7606       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7607       vv(1)=pizda(1,1)+pizda(2,2)
7608       vv(2)=pizda(2,1)-pizda(1,2)
7609       if (l.eq.j+1) then
7610         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7611      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7612      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7613       else
7614         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7615      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7616      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7617       endif
7618 C Cartesian gradient
7619       do iii=1,2
7620         do kkk=1,5
7621           do lll=1,3
7622             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7623      &        pizda(1,1))
7624             vv(1)=pizda(1,1)+pizda(2,2)
7625             vv(2)=pizda(2,1)-pizda(1,2)
7626             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7627      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7628      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7629           enddo
7630         enddo
7631       enddo
7632 cd      goto 1112
7633 cd1111  continue
7634       if (l.eq.j+1) then
7635 cd        goto 1110
7636 C Parallel orientation
7637 C Contribution from graph III
7638         call transpose2(EUg(1,1,l),auxmat(1,1))
7639         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7640         vv(1)=pizda(1,1)-pizda(2,2)
7641         vv(2)=pizda(1,2)+pizda(2,1)
7642         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7643      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7644 C Explicit gradient in virtual-dihedral angles.
7645         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7646      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7647      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7648         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7649         vv(1)=pizda(1,1)-pizda(2,2)
7650         vv(2)=pizda(1,2)+pizda(2,1)
7651         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7652      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7653      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7654         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7655         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7656         vv(1)=pizda(1,1)-pizda(2,2)
7657         vv(2)=pizda(1,2)+pizda(2,1)
7658         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7659      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7660      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7661 C Cartesian gradient
7662         do iii=1,2
7663           do kkk=1,5
7664             do lll=1,3
7665               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7666      &          pizda(1,1))
7667               vv(1)=pizda(1,1)-pizda(2,2)
7668               vv(2)=pizda(1,2)+pizda(2,1)
7669               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7670      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7671      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7672             enddo
7673           enddo
7674         enddo
7675 cd        goto 1112
7676 C Contribution from graph IV
7677 cd1110    continue
7678         call transpose2(EE(1,1,itl),auxmat(1,1))
7679         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7680         vv(1)=pizda(1,1)+pizda(2,2)
7681         vv(2)=pizda(2,1)-pizda(1,2)
7682         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7683      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7684 C Explicit gradient in virtual-dihedral angles.
7685         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7686      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7687         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7688         vv(1)=pizda(1,1)+pizda(2,2)
7689         vv(2)=pizda(2,1)-pizda(1,2)
7690         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7691      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7692      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7693 C Cartesian gradient
7694         do iii=1,2
7695           do kkk=1,5
7696             do lll=1,3
7697               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7698      &          pizda(1,1))
7699               vv(1)=pizda(1,1)+pizda(2,2)
7700               vv(2)=pizda(2,1)-pizda(1,2)
7701               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7702      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7703      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7704             enddo
7705           enddo
7706         enddo
7707       else
7708 C Antiparallel orientation
7709 C Contribution from graph III
7710 c        goto 1110
7711         call transpose2(EUg(1,1,j),auxmat(1,1))
7712         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7713         vv(1)=pizda(1,1)-pizda(2,2)
7714         vv(2)=pizda(1,2)+pizda(2,1)
7715         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7716      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7717 C Explicit gradient in virtual-dihedral angles.
7718         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7719      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7720      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7721         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7722         vv(1)=pizda(1,1)-pizda(2,2)
7723         vv(2)=pizda(1,2)+pizda(2,1)
7724         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7725      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7726      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7727         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7728         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7729         vv(1)=pizda(1,1)-pizda(2,2)
7730         vv(2)=pizda(1,2)+pizda(2,1)
7731         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7732      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7733      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7734 C Cartesian gradient
7735         do iii=1,2
7736           do kkk=1,5
7737             do lll=1,3
7738               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7739      &          pizda(1,1))
7740               vv(1)=pizda(1,1)-pizda(2,2)
7741               vv(2)=pizda(1,2)+pizda(2,1)
7742               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7743      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7744      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7745             enddo
7746           enddo
7747         enddo
7748 cd        goto 1112
7749 C Contribution from graph IV
7750 1110    continue
7751         call transpose2(EE(1,1,itj),auxmat(1,1))
7752         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7753         vv(1)=pizda(1,1)+pizda(2,2)
7754         vv(2)=pizda(2,1)-pizda(1,2)
7755         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7756      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7757 C Explicit gradient in virtual-dihedral angles.
7758         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7759      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7760         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7761         vv(1)=pizda(1,1)+pizda(2,2)
7762         vv(2)=pizda(2,1)-pizda(1,2)
7763         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7764      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7765      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7766 C Cartesian gradient
7767         do iii=1,2
7768           do kkk=1,5
7769             do lll=1,3
7770               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7771      &          pizda(1,1))
7772               vv(1)=pizda(1,1)+pizda(2,2)
7773               vv(2)=pizda(2,1)-pizda(1,2)
7774               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7775      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7776      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7777             enddo
7778           enddo
7779         enddo
7780       endif
7781 1112  continue
7782       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7783 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7784 cd        write (2,*) 'ijkl',i,j,k,l
7785 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7786 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7787 cd      endif
7788 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7789 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7790 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7791 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7792       if (j.lt.nres-1) then
7793         j1=j+1
7794         j2=j-1
7795       else
7796         j1=j-1
7797         j2=j-2
7798       endif
7799       if (l.lt.nres-1) then
7800         l1=l+1
7801         l2=l-1
7802       else
7803         l1=l-1
7804         l2=l-2
7805       endif
7806 cd      eij=1.0d0
7807 cd      ekl=1.0d0
7808 cd      ekont=1.0d0
7809 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7810 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7811 C        summed up outside the subrouine as for the other subroutines
7812 C        handling long-range interactions. The old code is commented out
7813 C        with "cgrad" to keep track of changes.
7814       do ll=1,3
7815 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7816 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7817         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7818         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7819 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7820 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7821 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7822 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7823 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7824 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7825 c     &   gradcorr5ij,
7826 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7827 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7828 cgrad        ghalf=0.5d0*ggg1(ll)
7829 cd        ghalf=0.0d0
7830         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7831         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7832         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7833         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7834         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7835         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7836 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7837 cgrad        ghalf=0.5d0*ggg2(ll)
7838 cd        ghalf=0.0d0
7839         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7840         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7841         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7842         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7843         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7844         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7845       enddo
7846 cd      goto 1112
7847 cgrad      do m=i+1,j-1
7848 cgrad        do ll=1,3
7849 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7850 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7851 cgrad        enddo
7852 cgrad      enddo
7853 cgrad      do m=k+1,l-1
7854 cgrad        do ll=1,3
7855 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7856 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7857 cgrad        enddo
7858 cgrad      enddo
7859 c1112  continue
7860 cgrad      do m=i+2,j2
7861 cgrad        do ll=1,3
7862 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7863 cgrad        enddo
7864 cgrad      enddo
7865 cgrad      do m=k+2,l2
7866 cgrad        do ll=1,3
7867 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7868 cgrad        enddo
7869 cgrad      enddo
7870 cd      do iii=1,nres-3
7871 cd        write (2,*) iii,g_corr5_loc(iii)
7872 cd      enddo
7873       eello5=ekont*eel5
7874 cd      write (2,*) 'ekont',ekont
7875 cd      write (iout,*) 'eello5',ekont*eel5
7876       return
7877       end
7878 c--------------------------------------------------------------------------
7879       double precision function eello6(i,j,k,l,jj,kk)
7880       implicit real*8 (a-h,o-z)
7881       include 'DIMENSIONS'
7882       include 'COMMON.IOUNITS'
7883       include 'COMMON.CHAIN'
7884       include 'COMMON.DERIV'
7885       include 'COMMON.INTERACT'
7886       include 'COMMON.CONTACTS'
7887 #ifdef MOMENT
7888       include 'COMMON.CONTACTS.MOMENT'
7889 #endif
7890       include 'COMMON.TORSION'
7891       include 'COMMON.VAR'
7892       include 'COMMON.GEO'
7893       include 'COMMON.FFIELD'
7894       double precision ggg1(3),ggg2(3)
7895 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7896 cd        eello6=0.0d0
7897 cd        return
7898 cd      endif
7899 cd      write (iout,*)
7900 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7901 cd     &   ' and',k,l
7902       eello6_1=0.0d0
7903       eello6_2=0.0d0
7904       eello6_3=0.0d0
7905       eello6_4=0.0d0
7906       eello6_5=0.0d0
7907       eello6_6=0.0d0
7908 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7909 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7910       do iii=1,2
7911         do kkk=1,5
7912           do lll=1,3
7913             derx(lll,kkk,iii)=0.0d0
7914           enddo
7915         enddo
7916       enddo
7917 cd      eij=facont_hb(jj,i)
7918 cd      ekl=facont_hb(kk,k)
7919 cd      ekont=eij*ekl
7920 cd      eij=1.0d0
7921 cd      ekl=1.0d0
7922 cd      ekont=1.0d0
7923       if (l.eq.j+1) then
7924         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7925         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7926         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7927         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7928         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7929         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7930       else
7931         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7932         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7933         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7934         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7935         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7936           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7937         else
7938           eello6_5=0.0d0
7939         endif
7940         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7941       endif
7942 C If turn contributions are considered, they will be handled separately.
7943       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7944 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7945 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7946 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7947 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7948 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7949 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7950 cd      goto 1112
7951       if (j.lt.nres-1) then
7952         j1=j+1
7953         j2=j-1
7954       else
7955         j1=j-1
7956         j2=j-2
7957       endif
7958       if (l.lt.nres-1) then
7959         l1=l+1
7960         l2=l-1
7961       else
7962         l1=l-1
7963         l2=l-2
7964       endif
7965       do ll=1,3
7966 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7967 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7968 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7969 cgrad        ghalf=0.5d0*ggg1(ll)
7970 cd        ghalf=0.0d0
7971         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7972         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7973         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7974         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7975         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7976         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7977         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7978         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7979 cgrad        ghalf=0.5d0*ggg2(ll)
7980 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7981 cd        ghalf=0.0d0
7982         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7983         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7984         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7985         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7986         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7987         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7988       enddo
7989 cd      goto 1112
7990 cgrad      do m=i+1,j-1
7991 cgrad        do ll=1,3
7992 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7993 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7994 cgrad        enddo
7995 cgrad      enddo
7996 cgrad      do m=k+1,l-1
7997 cgrad        do ll=1,3
7998 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7999 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8000 cgrad        enddo
8001 cgrad      enddo
8002 cgrad1112  continue
8003 cgrad      do m=i+2,j2
8004 cgrad        do ll=1,3
8005 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8006 cgrad        enddo
8007 cgrad      enddo
8008 cgrad      do m=k+2,l2
8009 cgrad        do ll=1,3
8010 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8011 cgrad        enddo
8012 cgrad      enddo
8013 cd      do iii=1,nres-3
8014 cd        write (2,*) iii,g_corr6_loc(iii)
8015 cd      enddo
8016       eello6=ekont*eel6
8017 cd      write (2,*) 'ekont',ekont
8018 cd      write (iout,*) 'eello6',ekont*eel6
8019       return
8020       end
8021 c--------------------------------------------------------------------------
8022       double precision function eello6_graph1(i,j,k,l,imat,swap)
8023       implicit real*8 (a-h,o-z)
8024       include 'DIMENSIONS'
8025       include 'COMMON.IOUNITS'
8026       include 'COMMON.CHAIN'
8027       include 'COMMON.DERIV'
8028       include 'COMMON.INTERACT'
8029       include 'COMMON.CONTACTS'
8030 #ifdef MOMENT
8031       include 'COMMON.CONTACTS.MOMENT'
8032 #endif
8033       include 'COMMON.TORSION'
8034       include 'COMMON.VAR'
8035       include 'COMMON.GEO'
8036       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8037       logical swap
8038       logical lprn
8039       common /kutas/ lprn
8040 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8041 C                                                                              C
8042 C      Parallel       Antiparallel                                             C
8043 C                                                                              C
8044 C          o             o                                                     C
8045 C         /l\           /j\                                                    C
8046 C        /   \         /   \                                                   C
8047 C       /| o |         | o |\                                                  C
8048 C     \ j|/k\|  /   \  |/k\|l /                                                C
8049 C      \ /   \ /     \ /   \ /                                                 C
8050 C       o     o       o     o                                                  C
8051 C       i             i                                                        C
8052 C                                                                              C
8053 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8054       itk=itortyp(itype(k))
8055       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8056       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8057       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8058       call transpose2(EUgC(1,1,k),auxmat(1,1))
8059       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8060       vv1(1)=pizda1(1,1)-pizda1(2,2)
8061       vv1(2)=pizda1(1,2)+pizda1(2,1)
8062       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8063       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8064       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8065       s5=scalar2(vv(1),Dtobr2(1,i))
8066 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8067       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8068       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8069      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8070      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8071      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8072      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8073      & +scalar2(vv(1),Dtobr2der(1,i)))
8074       call matmat2(AEAderg(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       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8078       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8079       if (l.eq.j+1) then
8080         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8081      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8082      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8083      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8084      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8085       else
8086         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8087      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8088      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8089      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8090      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8091       endif
8092       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8093       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8094       vv1(1)=pizda1(1,1)-pizda1(2,2)
8095       vv1(2)=pizda1(1,2)+pizda1(2,1)
8096       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8097      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8098      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8099      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8100       do iii=1,2
8101         if (swap) then
8102           ind=3-iii
8103         else
8104           ind=iii
8105         endif
8106         do kkk=1,5
8107           do lll=1,3
8108             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8109             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8110             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8111             call transpose2(EUgC(1,1,k),auxmat(1,1))
8112             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8113      &        pizda1(1,1))
8114             vv1(1)=pizda1(1,1)-pizda1(2,2)
8115             vv1(2)=pizda1(1,2)+pizda1(2,1)
8116             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8117             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8118      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8119             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8120      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8121             s5=scalar2(vv(1),Dtobr2(1,i))
8122             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8123           enddo
8124         enddo
8125       enddo
8126       return
8127       end
8128 c----------------------------------------------------------------------------
8129       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8130       implicit real*8 (a-h,o-z)
8131       include 'DIMENSIONS'
8132       include 'COMMON.IOUNITS'
8133       include 'COMMON.CHAIN'
8134       include 'COMMON.DERIV'
8135       include 'COMMON.INTERACT'
8136       include 'COMMON.CONTACTS'
8137 #ifdef MOMENT
8138       include 'COMMON.CONTACTS.MOMENT'
8139 #endif
8140       include 'COMMON.TORSION'
8141       include 'COMMON.VAR'
8142       include 'COMMON.GEO'
8143       logical swap
8144       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8145      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8146       logical lprn
8147       common /kutas/ lprn
8148 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8149 C                                                                              C
8150 C      Parallel       Antiparallel                                             C
8151 C                                                                              C
8152 C          o             o                                                     C
8153 C     \   /l\           /j\   /                                                C
8154 C      \ /   \         /   \ /                                                 C
8155 C       o| o |         | o |o                                                  C
8156 C     \ j|/k\|      \  |/k\|l                                                  C
8157 C      \ /   \       \ /   \                                                   C
8158 C       o             o                                                        C
8159 C       i             i                                                        C
8160 C                                                                              C
8161 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8162 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8163 C AL 7/4/01 s1 would occur in the sixth-order moment,
8164 C           but not in a cluster cumulant
8165 #ifdef MOMENT
8166       s1=dip(1,jj,i)*dip(1,kk,k)
8167 #endif
8168       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8169       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8170       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8171       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8172       call transpose2(EUg(1,1,k),auxmat(1,1))
8173       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8174       vv(1)=pizda(1,1)-pizda(2,2)
8175       vv(2)=pizda(1,2)+pizda(2,1)
8176       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8177 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8178 #ifdef MOMENT
8179       eello6_graph2=-(s1+s2+s3+s4)
8180 #else
8181       eello6_graph2=-(s2+s3+s4)
8182 #endif
8183 c      eello6_graph2=-s3
8184 C Derivatives in gamma(i-1)
8185       if (i.gt.1) then
8186 #ifdef MOMENT
8187         s1=dipderg(1,jj,i)*dip(1,kk,k)
8188 #endif
8189         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8190         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8191         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8192         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8193 #ifdef MOMENT
8194         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8195 #else
8196         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8197 #endif
8198 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8199       endif
8200 C Derivatives in gamma(k-1)
8201 #ifdef MOMENT
8202       s1=dip(1,jj,i)*dipderg(1,kk,k)
8203 #endif
8204       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8205       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8206       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8207       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8208       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8209       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8210       vv(1)=pizda(1,1)-pizda(2,2)
8211       vv(2)=pizda(1,2)+pizda(2,1)
8212       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8213 #ifdef MOMENT
8214       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8215 #else
8216       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8217 #endif
8218 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8219 C Derivatives in gamma(j-1) or gamma(l-1)
8220       if (j.gt.1) then
8221 #ifdef MOMENT
8222         s1=dipderg(3,jj,i)*dip(1,kk,k)
8223 #endif
8224         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8225         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8226         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8227         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8228         vv(1)=pizda(1,1)-pizda(2,2)
8229         vv(2)=pizda(1,2)+pizda(2,1)
8230         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8231 #ifdef MOMENT
8232         if (swap) then
8233           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8234         else
8235           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8236         endif
8237 #endif
8238         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8239 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8240       endif
8241 C Derivatives in gamma(l-1) or gamma(j-1)
8242       if (l.gt.1) then
8243 #ifdef MOMENT
8244         s1=dip(1,jj,i)*dipderg(3,kk,k)
8245 #endif
8246         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8247         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8248         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8249         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8250         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8251         vv(1)=pizda(1,1)-pizda(2,2)
8252         vv(2)=pizda(1,2)+pizda(2,1)
8253         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8254 #ifdef MOMENT
8255         if (swap) then
8256           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8257         else
8258           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8259         endif
8260 #endif
8261         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8262 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8263       endif
8264 C Cartesian derivatives.
8265       if (lprn) then
8266         write (2,*) 'In eello6_graph2'
8267         do iii=1,2
8268           write (2,*) 'iii=',iii
8269           do kkk=1,5
8270             write (2,*) 'kkk=',kkk
8271             do jjj=1,2
8272               write (2,'(3(2f10.5),5x)')
8273      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8274             enddo
8275           enddo
8276         enddo
8277       endif
8278       do iii=1,2
8279         do kkk=1,5
8280           do lll=1,3
8281 #ifdef MOMENT
8282             if (iii.eq.1) then
8283               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8284             else
8285               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8286             endif
8287 #endif
8288             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8289      &        auxvec(1))
8290             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8291             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8292      &        auxvec(1))
8293             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8294             call transpose2(EUg(1,1,k),auxmat(1,1))
8295             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8296      &        pizda(1,1))
8297             vv(1)=pizda(1,1)-pizda(2,2)
8298             vv(2)=pizda(1,2)+pizda(2,1)
8299             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8300 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8301 #ifdef MOMENT
8302             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8303 #else
8304             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8305 #endif
8306             if (swap) then
8307               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8308             else
8309               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8310             endif
8311           enddo
8312         enddo
8313       enddo
8314       return
8315       end
8316 c----------------------------------------------------------------------------
8317       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8318       implicit real*8 (a-h,o-z)
8319       include 'DIMENSIONS'
8320       include 'COMMON.IOUNITS'
8321       include 'COMMON.CHAIN'
8322       include 'COMMON.DERIV'
8323       include 'COMMON.INTERACT'
8324       include 'COMMON.CONTACTS'
8325 #ifdef MOMENT
8326       include 'COMMON.CONTACTS.MOMENT'
8327 #endif
8328       include 'COMMON.TORSION'
8329       include 'COMMON.VAR'
8330       include 'COMMON.GEO'
8331       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8332       logical swap
8333 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8334 C                                                                              C
8335 C      Parallel       Antiparallel                                             C
8336 C                                                                              C
8337 C          o             o                                                     C
8338 C         /l\   /   \   /j\                                                    C
8339 C        /   \ /     \ /   \                                                   C
8340 C       /| o |o       o| o |\                                                  C
8341 C       j|/k\|  /      |/k\|l /                                                C
8342 C        /   \ /       /   \ /                                                 C
8343 C       /     o       /     o                                                  C
8344 C       i             i                                                        C
8345 C                                                                              C
8346 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8347 C
8348 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8349 C           energy moment and not to the cluster cumulant.
8350       iti=itortyp(itype(i))
8351       if (j.lt.nres-1) then
8352         itj1=itortyp(itype(j+1))
8353       else
8354         itj1=ntortyp+1
8355       endif
8356       itk=itortyp(itype(k))
8357       itk1=itortyp(itype(k+1))
8358       if (l.lt.nres-1) then
8359         itl1=itortyp(itype(l+1))
8360       else
8361         itl1=ntortyp+1
8362       endif
8363 #ifdef MOMENT
8364       s1=dip(4,jj,i)*dip(4,kk,k)
8365 #endif
8366       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8367       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8368       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8369       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8370       call transpose2(EE(1,1,itk),auxmat(1,1))
8371       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8372       vv(1)=pizda(1,1)+pizda(2,2)
8373       vv(2)=pizda(2,1)-pizda(1,2)
8374       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8375 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8376 cd     & "sum",-(s2+s3+s4)
8377 #ifdef MOMENT
8378       eello6_graph3=-(s1+s2+s3+s4)
8379 #else
8380       eello6_graph3=-(s2+s3+s4)
8381 #endif
8382 c      eello6_graph3=-s4
8383 C Derivatives in gamma(k-1)
8384       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8385       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8386       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8387       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8388 C Derivatives in gamma(l-1)
8389       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8390       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8391       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8392       vv(1)=pizda(1,1)+pizda(2,2)
8393       vv(2)=pizda(2,1)-pizda(1,2)
8394       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8395       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8396 C Cartesian derivatives.
8397       do iii=1,2
8398         do kkk=1,5
8399           do lll=1,3
8400 #ifdef MOMENT
8401             if (iii.eq.1) then
8402               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8403             else
8404               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8405             endif
8406 #endif
8407             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8408      &        auxvec(1))
8409             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8410             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8411      &        auxvec(1))
8412             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8413             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8414      &        pizda(1,1))
8415             vv(1)=pizda(1,1)+pizda(2,2)
8416             vv(2)=pizda(2,1)-pizda(1,2)
8417             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8418 #ifdef MOMENT
8419             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8420 #else
8421             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8422 #endif
8423             if (swap) then
8424               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8425             else
8426               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8427             endif
8428 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8429           enddo
8430         enddo
8431       enddo
8432       return
8433       end
8434 c----------------------------------------------------------------------------
8435       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8436       implicit real*8 (a-h,o-z)
8437       include 'DIMENSIONS'
8438       include 'COMMON.IOUNITS'
8439       include 'COMMON.CHAIN'
8440       include 'COMMON.DERIV'
8441       include 'COMMON.INTERACT'
8442       include 'COMMON.CONTACTS'
8443 #ifdef MOMENT
8444       include 'COMMON.CONTACTS.MOMENT'
8445 #endif
8446       include 'COMMON.TORSION'
8447       include 'COMMON.VAR'
8448       include 'COMMON.GEO'
8449       include 'COMMON.FFIELD'
8450       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8451      & auxvec1(2),auxmat1(2,2)
8452       logical swap
8453 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8454 C                                                                              C
8455 C      Parallel       Antiparallel                                             C
8456 C                                                                              C
8457 C          o             o                                                     C
8458 C         /l\   /   \   /j\                                                    C
8459 C        /   \ /     \ /   \                                                   C
8460 C       /| o |o       o| o |\                                                  C
8461 C     \ j|/k\|      \  |/k\|l                                                  C
8462 C      \ /   \       \ /   \                                                   C
8463 C       o     \       o     \                                                  C
8464 C       i             i                                                        C
8465 C                                                                              C
8466 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8467 C
8468 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8469 C           energy moment and not to the cluster cumulant.
8470 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8471       iti=itortyp(itype(i))
8472       itj=itortyp(itype(j))
8473       if (j.lt.nres-1) then
8474         itj1=itortyp(itype(j+1))
8475       else
8476         itj1=ntortyp+1
8477       endif
8478       itk=itortyp(itype(k))
8479       if (k.lt.nres-1) then
8480         itk1=itortyp(itype(k+1))
8481       else
8482         itk1=ntortyp+1
8483       endif
8484       itl=itortyp(itype(l))
8485       if (l.lt.nres-1) then
8486         itl1=itortyp(itype(l+1))
8487       else
8488         itl1=ntortyp+1
8489       endif
8490 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8491 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8492 cd     & ' itl',itl,' itl1',itl1
8493 #ifdef MOMENT
8494       if (imat.eq.1) then
8495         s1=dip(3,jj,i)*dip(3,kk,k)
8496       else
8497         s1=dip(2,jj,j)*dip(2,kk,l)
8498       endif
8499 #endif
8500       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8501       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8502       if (j.eq.l+1) then
8503         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8504         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8505       else
8506         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8507         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8508       endif
8509       call transpose2(EUg(1,1,k),auxmat(1,1))
8510       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8511       vv(1)=pizda(1,1)-pizda(2,2)
8512       vv(2)=pizda(2,1)+pizda(1,2)
8513       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8514 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8515 #ifdef MOMENT
8516       eello6_graph4=-(s1+s2+s3+s4)
8517 #else
8518       eello6_graph4=-(s2+s3+s4)
8519 #endif
8520 C Derivatives in gamma(i-1)
8521       if (i.gt.1) then
8522 #ifdef MOMENT
8523         if (imat.eq.1) then
8524           s1=dipderg(2,jj,i)*dip(3,kk,k)
8525         else
8526           s1=dipderg(4,jj,j)*dip(2,kk,l)
8527         endif
8528 #endif
8529         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8530         if (j.eq.l+1) then
8531           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8532           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8533         else
8534           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8535           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8536         endif
8537         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8538         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8539 cd          write (2,*) 'turn6 derivatives'
8540 #ifdef MOMENT
8541           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8542 #else
8543           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8544 #endif
8545         else
8546 #ifdef MOMENT
8547           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8548 #else
8549           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8550 #endif
8551         endif
8552       endif
8553 C Derivatives in gamma(k-1)
8554 #ifdef MOMENT
8555       if (imat.eq.1) then
8556         s1=dip(3,jj,i)*dipderg(2,kk,k)
8557       else
8558         s1=dip(2,jj,j)*dipderg(4,kk,l)
8559       endif
8560 #endif
8561       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8562       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8563       if (j.eq.l+1) then
8564         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8565         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8566       else
8567         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8568         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8569       endif
8570       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8571       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8572       vv(1)=pizda(1,1)-pizda(2,2)
8573       vv(2)=pizda(2,1)+pizda(1,2)
8574       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8575       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8576 #ifdef MOMENT
8577         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8578 #else
8579         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8580 #endif
8581       else
8582 #ifdef MOMENT
8583         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8584 #else
8585         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8586 #endif
8587       endif
8588 C Derivatives in gamma(j-1) or gamma(l-1)
8589       if (l.eq.j+1 .and. l.gt.1) then
8590         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8591         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8592         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8593         vv(1)=pizda(1,1)-pizda(2,2)
8594         vv(2)=pizda(2,1)+pizda(1,2)
8595         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8596         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8597       else if (j.gt.1) then
8598         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8599         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8600         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8601         vv(1)=pizda(1,1)-pizda(2,2)
8602         vv(2)=pizda(2,1)+pizda(1,2)
8603         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8604         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8605           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8606         else
8607           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8608         endif
8609       endif
8610 C Cartesian derivatives.
8611       do iii=1,2
8612         do kkk=1,5
8613           do lll=1,3
8614 #ifdef MOMENT
8615             if (iii.eq.1) then
8616               if (imat.eq.1) then
8617                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8618               else
8619                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8620               endif
8621             else
8622               if (imat.eq.1) then
8623                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8624               else
8625                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8626               endif
8627             endif
8628 #endif
8629             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8630      &        auxvec(1))
8631             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8632             if (j.eq.l+1) then
8633               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8634      &          b1(1,itj1),auxvec(1))
8635               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8636             else
8637               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8638      &          b1(1,itl1),auxvec(1))
8639               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8640             endif
8641             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8642      &        pizda(1,1))
8643             vv(1)=pizda(1,1)-pizda(2,2)
8644             vv(2)=pizda(2,1)+pizda(1,2)
8645             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8646             if (swap) then
8647               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8648 #ifdef MOMENT
8649                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8650      &             -(s1+s2+s4)
8651 #else
8652                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8653      &             -(s2+s4)
8654 #endif
8655                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8656               else
8657 #ifdef MOMENT
8658                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8659 #else
8660                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8661 #endif
8662                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8663               endif
8664             else
8665 #ifdef MOMENT
8666               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8667 #else
8668               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8669 #endif
8670               if (l.eq.j+1) then
8671                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8672               else
8673                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8674               endif
8675             endif
8676           enddo
8677         enddo
8678       enddo
8679       return
8680       end
8681 c----------------------------------------------------------------------------
8682       double precision function eello_turn6(i,jj,kk)
8683       implicit real*8 (a-h,o-z)
8684       include 'DIMENSIONS'
8685       include 'COMMON.IOUNITS'
8686       include 'COMMON.CHAIN'
8687       include 'COMMON.DERIV'
8688       include 'COMMON.INTERACT'
8689       include 'COMMON.CONTACTS'
8690 #ifdef MOMENT
8691       include 'COMMON.CONTACTS.MOMENT'
8692 #endif
8693       include 'COMMON.TORSION'
8694       include 'COMMON.VAR'
8695       include 'COMMON.GEO'
8696       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8697      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8698      &  ggg1(3),ggg2(3)
8699       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8700      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8701 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8702 C           the respective energy moment and not to the cluster cumulant.
8703       s1=0.0d0
8704       s8=0.0d0
8705       s13=0.0d0
8706 c
8707       eello_turn6=0.0d0
8708       j=i+4
8709       k=i+1
8710       l=i+3
8711       iti=itortyp(itype(i))
8712       itk=itortyp(itype(k))
8713       itk1=itortyp(itype(k+1))
8714       itl=itortyp(itype(l))
8715       itj=itortyp(itype(j))
8716 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8717 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8718 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8719 cd        eello6=0.0d0
8720 cd        return
8721 cd      endif
8722 cd      write (iout,*)
8723 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8724 cd     &   ' and',k,l
8725 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8726       do iii=1,2
8727         do kkk=1,5
8728           do lll=1,3
8729             derx_turn(lll,kkk,iii)=0.0d0
8730           enddo
8731         enddo
8732       enddo
8733 cd      eij=1.0d0
8734 cd      ekl=1.0d0
8735 cd      ekont=1.0d0
8736       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8737 cd      eello6_5=0.0d0
8738 cd      write (2,*) 'eello6_5',eello6_5
8739 #ifdef MOMENT
8740       call transpose2(AEA(1,1,1),auxmat(1,1))
8741       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8742       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8743       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8744 #endif
8745       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8746       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8747       s2 = scalar2(b1(1,itk),vtemp1(1))
8748 #ifdef MOMENT
8749       call transpose2(AEA(1,1,2),atemp(1,1))
8750       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8751       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8752       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8753 #endif
8754       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8755       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8756       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8757 #ifdef MOMENT
8758       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8759       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8760       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8761       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8762       ss13 = scalar2(b1(1,itk),vtemp4(1))
8763       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8764 #endif
8765 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8766 c      s1=0.0d0
8767 c      s2=0.0d0
8768 c      s8=0.0d0
8769 c      s12=0.0d0
8770 c      s13=0.0d0
8771       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8772 C Derivatives in gamma(i+2)
8773       s1d =0.0d0
8774       s8d =0.0d0
8775 #ifdef MOMENT
8776       call transpose2(AEA(1,1,1),auxmatd(1,1))
8777       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8778       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8779       call transpose2(AEAderg(1,1,2),atempd(1,1))
8780       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8781       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8782 #endif
8783       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8784       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8785       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8786 c      s1d=0.0d0
8787 c      s2d=0.0d0
8788 c      s8d=0.0d0
8789 c      s12d=0.0d0
8790 c      s13d=0.0d0
8791       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8792 C Derivatives in gamma(i+3)
8793 #ifdef MOMENT
8794       call transpose2(AEA(1,1,1),auxmatd(1,1))
8795       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8796       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8797       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8798 #endif
8799       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8800       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8801       s2d = scalar2(b1(1,itk),vtemp1d(1))
8802 #ifdef MOMENT
8803       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8804       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8805 #endif
8806       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8807 #ifdef MOMENT
8808       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8809       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8810       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8811 #endif
8812 c      s1d=0.0d0
8813 c      s2d=0.0d0
8814 c      s8d=0.0d0
8815 c      s12d=0.0d0
8816 c      s13d=0.0d0
8817 #ifdef MOMENT
8818       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8819      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8820 #else
8821       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8822      &               -0.5d0*ekont*(s2d+s12d)
8823 #endif
8824 C Derivatives in gamma(i+4)
8825       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8826       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8827       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8828 #ifdef MOMENT
8829       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8830       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8831       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8832 #endif
8833 c      s1d=0.0d0
8834 c      s2d=0.0d0
8835 c      s8d=0.0d0
8836 C      s12d=0.0d0
8837 c      s13d=0.0d0
8838 #ifdef MOMENT
8839       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8840 #else
8841       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8842 #endif
8843 C Derivatives in gamma(i+5)
8844 #ifdef MOMENT
8845       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8846       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8847       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8848 #endif
8849       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8850       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8851       s2d = scalar2(b1(1,itk),vtemp1d(1))
8852 #ifdef MOMENT
8853       call transpose2(AEA(1,1,2),atempd(1,1))
8854       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8855       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8856 #endif
8857       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8858       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8859 #ifdef MOMENT
8860       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8861       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8862       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8863 #endif
8864 c      s1d=0.0d0
8865 c      s2d=0.0d0
8866 c      s8d=0.0d0
8867 c      s12d=0.0d0
8868 c      s13d=0.0d0
8869 #ifdef MOMENT
8870       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8871      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8872 #else
8873       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8874      &               -0.5d0*ekont*(s2d+s12d)
8875 #endif
8876 C Cartesian derivatives
8877       do iii=1,2
8878         do kkk=1,5
8879           do lll=1,3
8880 #ifdef MOMENT
8881             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8882             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8883             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8884 #endif
8885             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8886             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8887      &          vtemp1d(1))
8888             s2d = scalar2(b1(1,itk),vtemp1d(1))
8889 #ifdef MOMENT
8890             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8891             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8892             s8d = -(atempd(1,1)+atempd(2,2))*
8893      &           scalar2(cc(1,1,itl),vtemp2(1))
8894 #endif
8895             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8896      &           auxmatd(1,1))
8897             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8898             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8899 c      s1d=0.0d0
8900 c      s2d=0.0d0
8901 c      s8d=0.0d0
8902 c      s12d=0.0d0
8903 c      s13d=0.0d0
8904 #ifdef MOMENT
8905             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8906      &        - 0.5d0*(s1d+s2d)
8907 #else
8908             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8909      &        - 0.5d0*s2d
8910 #endif
8911 #ifdef MOMENT
8912             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8913      &        - 0.5d0*(s8d+s12d)
8914 #else
8915             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8916      &        - 0.5d0*s12d
8917 #endif
8918           enddo
8919         enddo
8920       enddo
8921 #ifdef MOMENT
8922       do kkk=1,5
8923         do lll=1,3
8924           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8925      &      achuj_tempd(1,1))
8926           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8927           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8928           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8929           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8930           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8931      &      vtemp4d(1))
8932           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8933           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8934           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8935         enddo
8936       enddo
8937 #endif
8938 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8939 cd     &  16*eel_turn6_num
8940 cd      goto 1112
8941       if (j.lt.nres-1) then
8942         j1=j+1
8943         j2=j-1
8944       else
8945         j1=j-1
8946         j2=j-2
8947       endif
8948       if (l.lt.nres-1) then
8949         l1=l+1
8950         l2=l-1
8951       else
8952         l1=l-1
8953         l2=l-2
8954       endif
8955       do ll=1,3
8956 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8957 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8958 cgrad        ghalf=0.5d0*ggg1(ll)
8959 cd        ghalf=0.0d0
8960         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8961         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8962         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8963      &    +ekont*derx_turn(ll,2,1)
8964         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8965         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8966      &    +ekont*derx_turn(ll,4,1)
8967         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8968         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8969         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8970 cgrad        ghalf=0.5d0*ggg2(ll)
8971 cd        ghalf=0.0d0
8972         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8973      &    +ekont*derx_turn(ll,2,2)
8974         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8975         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8976      &    +ekont*derx_turn(ll,4,2)
8977         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8978         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8979         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8980       enddo
8981 cd      goto 1112
8982 cgrad      do m=i+1,j-1
8983 cgrad        do ll=1,3
8984 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8985 cgrad        enddo
8986 cgrad      enddo
8987 cgrad      do m=k+1,l-1
8988 cgrad        do ll=1,3
8989 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8990 cgrad        enddo
8991 cgrad      enddo
8992 cgrad1112  continue
8993 cgrad      do m=i+2,j2
8994 cgrad        do ll=1,3
8995 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8996 cgrad        enddo
8997 cgrad      enddo
8998 cgrad      do m=k+2,l2
8999 cgrad        do ll=1,3
9000 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9001 cgrad        enddo
9002 cgrad      enddo
9003 cd      do iii=1,nres-3
9004 cd        write (2,*) iii,g_corr6_loc(iii)
9005 cd      enddo
9006       eello_turn6=ekont*eel_turn6
9007 cd      write (2,*) 'ekont',ekont
9008 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9009       return
9010       end
9011
9012 C-----------------------------------------------------------------------------
9013       double precision function scalar(u,v)
9014 !DIR$ INLINEALWAYS scalar
9015 #ifndef OSF
9016 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9017 #endif
9018       implicit none
9019       double precision u(3),v(3)
9020 cd      double precision sc
9021 cd      integer i
9022 cd      sc=0.0d0
9023 cd      do i=1,3
9024 cd        sc=sc+u(i)*v(i)
9025 cd      enddo
9026 cd      scalar=sc
9027
9028       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9029       return
9030       end
9031 crc-------------------------------------------------
9032       SUBROUTINE MATVEC2(A1,V1,V2)
9033 !DIR$ INLINEALWAYS MATVEC2
9034 #ifndef OSF
9035 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9036 #endif
9037       implicit real*8 (a-h,o-z)
9038       include 'DIMENSIONS'
9039       DIMENSION A1(2,2),V1(2),V2(2)
9040 c      DO 1 I=1,2
9041 c        VI=0.0
9042 c        DO 3 K=1,2
9043 c    3     VI=VI+A1(I,K)*V1(K)
9044 c        Vaux(I)=VI
9045 c    1 CONTINUE
9046
9047       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9048       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9049
9050       v2(1)=vaux1
9051       v2(2)=vaux2
9052       END
9053 C---------------------------------------
9054       SUBROUTINE MATMAT2(A1,A2,A3)
9055 #ifndef OSF
9056 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9057 #endif
9058       implicit real*8 (a-h,o-z)
9059       include 'DIMENSIONS'
9060       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9061 c      DIMENSION AI3(2,2)
9062 c        DO  J=1,2
9063 c          A3IJ=0.0
9064 c          DO K=1,2
9065 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9066 c          enddo
9067 c          A3(I,J)=A3IJ
9068 c       enddo
9069 c      enddo
9070
9071       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9072       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9073       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9074       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9075
9076       A3(1,1)=AI3_11
9077       A3(2,1)=AI3_21
9078       A3(1,2)=AI3_12
9079       A3(2,2)=AI3_22
9080       END
9081
9082 c-------------------------------------------------------------------------
9083       double precision function scalar2(u,v)
9084 !DIR$ INLINEALWAYS scalar2
9085       implicit none
9086       double precision u(2),v(2)
9087       double precision sc
9088       integer i
9089       scalar2=u(1)*v(1)+u(2)*v(2)
9090       return
9091       end
9092
9093 C-----------------------------------------------------------------------------
9094
9095       subroutine transpose2(a,at)
9096 !DIR$ INLINEALWAYS transpose2
9097 #ifndef OSF
9098 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9099 #endif
9100       implicit none
9101       double precision a(2,2),at(2,2)
9102       at(1,1)=a(1,1)
9103       at(1,2)=a(2,1)
9104       at(2,1)=a(1,2)
9105       at(2,2)=a(2,2)
9106       return
9107       end
9108 c--------------------------------------------------------------------------
9109       subroutine transpose(n,a,at)
9110       implicit none
9111       integer n,i,j
9112       double precision a(n,n),at(n,n)
9113       do i=1,n
9114         do j=1,n
9115           at(j,i)=a(i,j)
9116         enddo
9117       enddo
9118       return
9119       end
9120 C---------------------------------------------------------------------------
9121       subroutine prodmat3(a1,a2,kk,transp,prod)
9122 !DIR$ INLINEALWAYS prodmat3
9123 #ifndef OSF
9124 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9125 #endif
9126       implicit none
9127       integer i,j
9128       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9129       logical transp
9130 crc      double precision auxmat(2,2),prod_(2,2)
9131
9132       if (transp) then
9133 crc        call transpose2(kk(1,1),auxmat(1,1))
9134 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9135 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9136
9137            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9138      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9139            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9140      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9141            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9142      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9143            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9144      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9145
9146       else
9147 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9148 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9149
9150            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9151      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9152            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9153      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9154            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9155      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9156            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9157      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9158
9159       endif
9160 c      call transpose2(a2(1,1),a2t(1,1))
9161
9162 crc      print *,transp
9163 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9164 crc      print *,((prod(i,j),i=1,2),j=1,2)
9165
9166       return
9167       end
9168