source/wham/src-M/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15 #ifdef MPL
  16       include 'COMMON.INFO'
  17       external d_vadd
  18       integer ready
  19 #endif
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       double precision fact(6)
  26 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw,evdw_t)
  34 cd    print '(a)','Exit ELJ'
  35       goto 106
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw,evdw_t)
  38       goto 106
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw,evdw_t)
  41       goto 106
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw,evdw_t)
  44       goto 106
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw,evdw_t)
  47 C
  48 C Calculate electrostatic (H-bonding) energy of the main chain.
  49 C
  50   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  51 C
  52 C Calculate excluded-volume interaction energy between peptide groups
  53 C and side chains.
  54 C
  55       call escp(evdw2,evdw2_14)
  56 c
  57 c Calculate the bond-stretching energy
  58 c
  59       call ebond(estr)
  60 c      write (iout,*) "estr",estr
  61 C
  62 C Calculate the disulfide-bridge and other energy and the contributions
  63 C from other distance constraints.
  64 cd    print *,'Calling EHPB'
  65       call edis(ehpb)
  66 cd    print *,'EHPB exitted succesfully.'
  67 C
  68 C Calculate the virtual-bond-angle energy.
  69 C
  70       call ebend(ebe,ethetacnstr)
  71 cd    print *,'Bend energy finished.'
  72 C
  73 C Calculate the SC local energy.
  74 C
  75       call esc(escloc)
  76 cd    print *,'SCLOC energy finished.'
  77 C
  78 C Calculate the virtual-bond torsional energy.
  79 C
  80 cd    print *,'nterm=',nterm
  81       call etor(etors,edihcnstr,fact(1))
  82 C
  83 C 6/23/01 Calculate double-torsional energy
  84 C
  85       call etor_d(etors_d,fact(2))
  86 C
  87 C 21/5/07 Calculate local sicdechain correlation energy
  88 C
  89       call eback_sc_corr(esccor)
  90 C
  91 C 12/1/95 Multi-body terms
  92 C
  93       n_corr=0
  94       n_corr1=0
  95       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  96      &    .or. wturn6.gt.0.0d0) then
  97 c         print *,"calling multibody_eello"
  98          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
  99 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 100 c         print *,ecorr,ecorr5,ecorr6,eturn6
 101       endif
 102       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 103          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 104       endif
 105 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 106 #ifdef SPLITELE
 107       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 108      & +wvdwpp*evdw1
 109      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 110      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 111      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 112      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 113      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 114      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 115 #else
 116       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 117      & +welec*fact(1)*(ees+evdw1)
 118      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 119      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 120      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 121      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 122      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 123      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 124 #endif
 125       energia(0)=etot
 126       energia(1)=evdw
 127 #ifdef SCP14
 128       energia(2)=evdw2-evdw2_14
 129       energia(17)=evdw2_14
 130 #else
 131       energia(2)=evdw2
 132       energia(17)=0.0d0
 133 #endif
 134 #ifdef SPLITELE
 135       energia(3)=ees
 136       energia(16)=evdw1
 137 #else
 138       energia(3)=ees+evdw1
 139       energia(16)=0.0d0
 140 #endif
 141       energia(4)=ecorr
 142       energia(5)=ecorr5
 143       energia(6)=ecorr6
 144       energia(7)=eel_loc
 145       energia(8)=eello_turn3
 146       energia(9)=eello_turn4
 147       energia(10)=eturn6
 148       energia(11)=ebe
 149       energia(12)=escloc
 150       energia(13)=etors
 151       energia(14)=etors_d
 152       energia(15)=ehpb
 153       energia(18)=estr
 154       energia(19)=esccor
 155       energia(20)=edihcnstr
 156       energia(21)=evdw_t
 157       energia(24)=ethetacnstr
 158 c detecting NaNQ
 159 #ifdef ISNAN
 160 #ifdef AIX
 161       if (isnan(etot).ne.0) energia(0)=1.0d+99
 162 #else
 163       if (isnan(etot)) energia(0)=1.0d+99
 164 #endif
 165 #else
 166       i=0
 167 #ifdef WINPGI
 168       idumm=proc_proc(etot,i)
 169 #else
 170       call proc_proc(etot,i)
 171 #endif
 172       if(i.eq.1)energia(0)=1.0d+99
 173 #endif
 174 #ifdef MPL
 175 c     endif
 176 #endif
 177       if (calc_grad) then
 178 C
 179 C Sum up the components of the Cartesian gradient.
 180 C
 181 #ifdef SPLITELE
 182       do i=1,nct
 183         do j=1,3
 184           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 185      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 186      &                wbond*gradb(j,i)+
 187      &                wstrain*ghpbc(j,i)+
 188      &                wcorr*fact(3)*gradcorr(j,i)+
 189      &                wel_loc*fact(2)*gel_loc(j,i)+
 190      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 191      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 192      &                wcorr5*fact(4)*gradcorr5(j,i)+
 193      &                wcorr6*fact(5)*gradcorr6(j,i)+
 194      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 195      &                wsccor*fact(2)*gsccorc(j,i)
 196           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 197      &                  wbond*gradbx(j,i)+
 198      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 199      &                  wsccor*fact(2)*gsccorx(j,i)
 200         enddo
 201 #else
 202       do i=1,nct
 203         do j=1,3
 204           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 205      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 206      &                wbond*gradb(j,i)+
 207      &                wcorr*fact(3)*gradcorr(j,i)+
 208      &                wel_loc*fact(2)*gel_loc(j,i)+
 209      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 210      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 211      &                wcorr5*fact(4)*gradcorr5(j,i)+
 212      &                wcorr6*fact(5)*gradcorr6(j,i)+
 213      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 214      &                wsccor*fact(2)*gsccorc(j,i)
 215           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 216      &                  wbond*gradbx(j,i)+
 217      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 218      &                  wsccor*fact(1)*gsccorx(j,i)
 219         enddo
 220 #endif
 221       enddo
 222
 223
 224       do i=1,nres-3
 225         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 226      &   +wcorr5*fact(4)*g_corr5_loc(i)
 227      &   +wcorr6*fact(5)*g_corr6_loc(i)
 228      &   +wturn4*fact(3)*gel_loc_turn4(i)
 229      &   +wturn3*fact(2)*gel_loc_turn3(i)
 230      &   +wturn6*fact(5)*gel_loc_turn6(i)
 231      &   +wel_loc*fact(2)*gel_loc_loc(i)
 232 c     &   +wsccor*fact(1)*gsccor_loc(i)
 233 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 234       enddo
 235       endif
 236       if (dyn_ss) call dyn_set_nss
 237       return
 238       end
 239 C------------------------------------------------------------------------
 240       subroutine enerprint(energia,fact)
 241       implicit real*8 (a-h,o-z)
 242       include 'DIMENSIONS'
 243       include 'DIMENSIONS.ZSCOPT'
 244       include 'COMMON.IOUNITS'
 245       include 'COMMON.FFIELD'
 246       include 'COMMON.SBRIDGE'
 247       double precision energia(0:max_ene),fact(6)
 248       etot=energia(0)
 249       evdw=energia(1)+fact(6)*energia(21)
 250 #ifdef SCP14
 251       evdw2=energia(2)+energia(17)
 252 #else
 253       evdw2=energia(2)
 254 #endif
 255       ees=energia(3)
 256 #ifdef SPLITELE
 257       evdw1=energia(16)
 258 #endif
 259       ecorr=energia(4)
 260       ecorr5=energia(5)
 261       ecorr6=energia(6)
 262       eel_loc=energia(7)
 263       eello_turn3=energia(8)
 264       eello_turn4=energia(9)
 265       eello_turn6=energia(10)
 266       ebe=energia(11)
 267       escloc=energia(12)
 268       etors=energia(13)
 269       etors_d=energia(14)
 270       ehpb=energia(15)
 271       esccor=energia(19)
 272       edihcnstr=energia(20)
 273       estr=energia(18)
 274       ethetacnstr=energia(24)
 275 #ifdef SPLITELE
 276       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 277      &  wvdwpp,
 278      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 279      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 280      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 281      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 282      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 283      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,etot
 284    10 format (/'Virtual-chain energies:'//
 285      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 286      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 287      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 288      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 289      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 290      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 291      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 292      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 293      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 294      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 295      & ' (SS bridges & dist. cnstr.)'/
 296      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 297      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 298      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 299      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 300      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 301      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 302      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 303      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 304      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 305      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 306      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 307      & 'ETOT=  ',1pE16.6,' (total)')
 308 #else
 309       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 310      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 311      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 312      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 313      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 314      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 315      &  edihcnstr,ethetacnstr,ebr*nss,etot
 316    10 format (/'Virtual-chain energies:'//
 317      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 318      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 319      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 320      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 321      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 322      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 323      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 324      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 325      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 326      & ' (SS bridges & dist. cnstr.)'/
 327      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 328      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 329      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 330      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 331      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 332      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 333      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 334      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 335      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 336      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 337      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 338      & 'ETOT=  ',1pE16.6,' (total)')
 339 #endif
 340       return
 341       end
 342 C-----------------------------------------------------------------------
 343       subroutine elj(evdw,evdw_t)
 344 C
 345 C This subroutine calculates the interaction energy of nonbonded side chains
 346 C assuming the LJ potential of interaction.
 347 C
 348       implicit real*8 (a-h,o-z)
 349       include 'DIMENSIONS'
 350       include 'DIMENSIONS.ZSCOPT'
 351       include "DIMENSIONS.COMPAR"
 352       parameter (accur=1.0d-10)
 353       include 'COMMON.GEO'
 354       include 'COMMON.VAR'
 355       include 'COMMON.LOCAL'
 356       include 'COMMON.CHAIN'
 357       include 'COMMON.DERIV'
 358       include 'COMMON.INTERACT'
 359       include 'COMMON.TORSION'
 360       include 'COMMON.ENEPS'
 361       include 'COMMON.SBRIDGE'
 362       include 'COMMON.NAMES'
 363       include 'COMMON.IOUNITS'
 364       include 'COMMON.CONTACTS'
 365       dimension gg(3)
 366       integer icant
 367       external icant
 368 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 369 c ROZNICA z cluster
 370       do i=1,210
 371         do j=1,2
 372           eneps_temp(j,i)=0.0d0
 373         enddo
 374       enddo
 375 cROZNICA
 376
 377       evdw=0.0D0
 378       evdw_t=0.0d0
 379       do i=iatsc_s,iatsc_e
 380         itypi=iabs(itype(i))
 381         if (itypi.eq.ntyp1) cycle
 382         itypi1=iabs(itype(i+1))
 383         xi=c(1,nres+i)
 384         yi=c(2,nres+i)
 385         zi=c(3,nres+i)
 386 C Change 12/1/95
 387         num_conti=0
 388 C
 389 C Calculate SC interaction energy.
 390 C
 391         do iint=1,nint_gr(i)
 392 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 393 cd   &                  'iend=',iend(i,iint)
 394           do j=istart(i,iint),iend(i,iint)
 395             itypj=iabs(itype(j))
 396             if (itypj.eq.ntyp1) cycle
 397             xj=c(1,nres+j)-xi
 398             yj=c(2,nres+j)-yi
 399             zj=c(3,nres+j)-zi
 400 C Change 12/1/95 to calculate four-body interactions
 401             rij=xj*xj+yj*yj+zj*zj
 402             rrij=1.0D0/rij
 403 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 404             eps0ij=eps(itypi,itypj)
 405             fac=rrij**expon2
 406             e1=fac*fac*aa(itypi,itypj)
 407             e2=fac*bb(itypi,itypj)
 408             evdwij=e1+e2
 409             ij=icant(itypi,itypj)
 410 c ROZNICA z cluster
 411             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 412             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 413 c
 414
 415 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 416 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 417 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 418 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 419 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 420 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 421             if (bb(itypi,itypj).gt.0.0d0) then
 422               evdw=evdw+evdwij
 423             else
 424               evdw_t=evdw_t+evdwij
 425             endif
 426             if (calc_grad) then
 427 C
 428 C Calculate the components of the gradient in DC and X
 429 C
 430             fac=-rrij*(e1+evdwij)
 431             gg(1)=xj*fac
 432             gg(2)=yj*fac
 433             gg(3)=zj*fac
 434             do k=1,3
 435               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 436               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 437             enddo
 438             do k=i,j-1
 439               do l=1,3
 440                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 441               enddo
 442             enddo
 443             endif
 444 C
 445 C 12/1/95, revised on 5/20/97
 446 C
 447 C Calculate the contact function. The ith column of the array JCONT will
 448 C contain the numbers of atoms that make contacts with the atom I (of numbers
 449 C greater than I). The arrays FACONT and GACONT will contain the values of
 450 C the contact function and its derivative.
 451 C
 452 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 453 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 454 C Uncomment next line, if the correlation interactions are contact function only
 455             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 456               rij=dsqrt(rij)
 457               sigij=sigma(itypi,itypj)
 458               r0ij=rs0(itypi,itypj)
 459 C
 460 C Check whether the SC's are not too far to make a contact.
 461 C
 462               rcut=1.5d0*r0ij
 463               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 464 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 465 C
 466               if (fcont.gt.0.0D0) then
 467 C If the SC-SC distance if close to sigma, apply spline.
 468 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 469 cAdam &             fcont1,fprimcont1)
 470 cAdam           fcont1=1.0d0-fcont1
 471 cAdam           if (fcont1.gt.0.0d0) then
 472 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 473 cAdam             fcont=fcont*fcont1
 474 cAdam           endif
 475 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 476 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 477 cga             do k=1,3
 478 cga               gg(k)=gg(k)*eps0ij
 479 cga             enddo
 480 cga             eps0ij=-evdwij*eps0ij
 481 C Uncomment for AL's type of SC correlation interactions.
 482 cadam           eps0ij=-evdwij
 483                 num_conti=num_conti+1
 484                 jcont(num_conti,i)=j
 485                 facont(num_conti,i)=fcont*eps0ij
 486                 fprimcont=eps0ij*fprimcont/rij
 487                 fcont=expon*fcont
 488 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 489 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 490 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 491 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 492                 gacont(1,num_conti,i)=-fprimcont*xj
 493                 gacont(2,num_conti,i)=-fprimcont*yj
 494                 gacont(3,num_conti,i)=-fprimcont*zj
 495 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 496 cd              write (iout,'(2i3,3f10.5)')
 497 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 498               endif
 499             endif
 500           enddo      ! j
 501         enddo        ! iint
 502 C Change 12/1/95
 503         num_cont(i)=num_conti
 504       enddo          ! i
 505       if (calc_grad) then
 506       do i=1,nct
 507         do j=1,3
 508           gvdwc(j,i)=expon*gvdwc(j,i)
 509           gvdwx(j,i)=expon*gvdwx(j,i)
 510         enddo
 511       enddo
 512       endif
 513 C******************************************************************************
 514 C
 515 C                              N O T E !!!
 516 C
 517 C To save time, the factor of EXPON has been extracted from ALL components
 518 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 519 C use!
 520 C
 521 C******************************************************************************
 522       return
 523       end
 524 C-----------------------------------------------------------------------------
 525       subroutine eljk(evdw,evdw_t)
 526 C
 527 C This subroutine calculates the interaction energy of nonbonded side chains
 528 C assuming the LJK potential of interaction.
 529 C
 530       implicit real*8 (a-h,o-z)
 531       include 'DIMENSIONS'
 532       include 'DIMENSIONS.ZSCOPT'
 533       include "DIMENSIONS.COMPAR"
 534       include 'COMMON.GEO'
 535       include 'COMMON.VAR'
 536       include 'COMMON.LOCAL'
 537       include 'COMMON.CHAIN'
 538       include 'COMMON.DERIV'
 539       include 'COMMON.INTERACT'
 540       include 'COMMON.ENEPS'
 541       include 'COMMON.IOUNITS'
 542       include 'COMMON.NAMES'
 543       dimension gg(3)
 544       logical scheck
 545       integer icant
 546       external icant
 547 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 548       do i=1,210
 549         do j=1,2
 550           eneps_temp(j,i)=0.0d0
 551         enddo
 552       enddo
 553       evdw=0.0D0
 554       evdw_t=0.0d0
 555       do i=iatsc_s,iatsc_e
 556         itypi=iabs(itype(i))
 557         if (itypi.eq.ntyp1) cycle
 558         itypi1=iabs(itype(i+1))
 559         xi=c(1,nres+i)
 560         yi=c(2,nres+i)
 561         zi=c(3,nres+i)
 562 C
 563 C Calculate SC interaction energy.
 564 C
 565         do iint=1,nint_gr(i)
 566           do j=istart(i,iint),iend(i,iint)
 567             itypj=iabs(itype(j))
 568             if (itypj.eq.ntyp1) cycle
 569             xj=c(1,nres+j)-xi
 570             yj=c(2,nres+j)-yi
 571             zj=c(3,nres+j)-zi
 572             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 573             fac_augm=rrij**expon
 574             e_augm=augm(itypi,itypj)*fac_augm
 575             r_inv_ij=dsqrt(rrij)
 576             rij=1.0D0/r_inv_ij
 577             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 578             fac=r_shift_inv**expon
 579             e1=fac*fac*aa(itypi,itypj)
 580             e2=fac*bb(itypi,itypj)
 581             evdwij=e_augm+e1+e2
 582             ij=icant(itypi,itypj)
 583             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 584      &        /dabs(eps(itypi,itypj))
 585             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 586 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 587 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 588 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 589 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 590 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 591 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 592 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 593             if (bb(itypi,itypj).gt.0.0d0) then
 594               evdw=evdw+evdwij
 595             else
 596               evdw_t=evdw_t+evdwij
 597             endif
 598             if (calc_grad) then
 599 C
 600 C Calculate the components of the gradient in DC and X
 601 C
 602             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 603             gg(1)=xj*fac
 604             gg(2)=yj*fac
 605             gg(3)=zj*fac
 606             do k=1,3
 607               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 608               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 609             enddo
 610             do k=i,j-1
 611               do l=1,3
 612                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 613               enddo
 614             enddo
 615             endif
 616           enddo      ! j
 617         enddo        ! iint
 618       enddo          ! i
 619       if (calc_grad) then
 620       do i=1,nct
 621         do j=1,3
 622           gvdwc(j,i)=expon*gvdwc(j,i)
 623           gvdwx(j,i)=expon*gvdwx(j,i)
 624         enddo
 625       enddo
 626       endif
 627       return
 628       end
 629 C-----------------------------------------------------------------------------
 630       subroutine ebp(evdw,evdw_t)
 631 C
 632 C This subroutine calculates the interaction energy of nonbonded side chains
 633 C assuming the Berne-Pechukas potential of interaction.
 634 C
 635       implicit real*8 (a-h,o-z)
 636       include 'DIMENSIONS'
 637       include 'DIMENSIONS.ZSCOPT'
 638       include "DIMENSIONS.COMPAR"
 639       include 'COMMON.GEO'
 640       include 'COMMON.VAR'
 641       include 'COMMON.LOCAL'
 642       include 'COMMON.CHAIN'
 643       include 'COMMON.DERIV'
 644       include 'COMMON.NAMES'
 645       include 'COMMON.INTERACT'
 646       include 'COMMON.ENEPS'
 647       include 'COMMON.IOUNITS'
 648       include 'COMMON.CALC'
 649       common /srutu/ icall
 650 c     double precision rrsave(maxdim)
 651       logical lprn
 652       integer icant
 653       external icant
 654       do i=1,210
 655         do j=1,2
 656           eneps_temp(j,i)=0.0d0
 657         enddo
 658       enddo
 659       evdw=0.0D0
 660       evdw_t=0.0d0
 661 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 662 c     if (icall.eq.0) then
 663 c       lprn=.true.
 664 c     else
 665         lprn=.false.
 666 c     endif
 667       ind=0
 668       do i=iatsc_s,iatsc_e
 669         itypi=iabs(itype(i))
 670         if (itypi.eq.ntyp1) cycle
 671         itypi1=iabs(itype(i+1))
 672         xi=c(1,nres+i)
 673         yi=c(2,nres+i)
 674         zi=c(3,nres+i)
 675         dxi=dc_norm(1,nres+i)
 676         dyi=dc_norm(2,nres+i)
 677         dzi=dc_norm(3,nres+i)
 678         dsci_inv=vbld_inv(i+nres)
 679 C
 680 C Calculate SC interaction energy.
 681 C
 682         do iint=1,nint_gr(i)
 683           do j=istart(i,iint),iend(i,iint)
 684             ind=ind+1
 685             itypj=iabs(itype(j))
 686             if (itypj.eq.ntyp1) cycle
 687             dscj_inv=vbld_inv(j+nres)
 688             chi1=chi(itypi,itypj)
 689             chi2=chi(itypj,itypi)
 690             chi12=chi1*chi2
 691             chip1=chip(itypi)
 692             chip2=chip(itypj)
 693             chip12=chip1*chip2
 694             alf1=alp(itypi)
 695             alf2=alp(itypj)
 696             alf12=0.5D0*(alf1+alf2)
 697 C For diagnostics only!!!
 698 c           chi1=0.0D0
 699 c           chi2=0.0D0
 700 c           chi12=0.0D0
 701 c           chip1=0.0D0
 702 c           chip2=0.0D0
 703 c           chip12=0.0D0
 704 c           alf1=0.0D0
 705 c           alf2=0.0D0
 706 c           alf12=0.0D0
 707             xj=c(1,nres+j)-xi
 708             yj=c(2,nres+j)-yi
 709             zj=c(3,nres+j)-zi
 710             dxj=dc_norm(1,nres+j)
 711             dyj=dc_norm(2,nres+j)
 712             dzj=dc_norm(3,nres+j)
 713             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 714 cd          if (icall.eq.0) then
 715 cd            rrsave(ind)=rrij
 716 cd          else
 717 cd            rrij=rrsave(ind)
 718 cd          endif
 719             rij=dsqrt(rrij)
 720 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 721             call sc_angular
 722 C Calculate whole angle-dependent part of epsilon and contributions
 723 C to its derivatives
 724             fac=(rrij*sigsq)**expon2
 725             e1=fac*fac*aa(itypi,itypj)
 726             e2=fac*bb(itypi,itypj)
 727             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 728             eps2der=evdwij*eps3rt
 729             eps3der=evdwij*eps2rt
 730             evdwij=evdwij*eps2rt*eps3rt
 731             ij=icant(itypi,itypj)
 732             aux=eps1*eps2rt**2*eps3rt**2
 733             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 734      &        /dabs(eps(itypi,itypj))
 735             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 736             if (bb(itypi,itypj).gt.0.0d0) then
 737               evdw=evdw+evdwij
 738             else
 739               evdw_t=evdw_t+evdwij
 740             endif
 741             if (calc_grad) then
 742             if (lprn) then
 743             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 744             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 745             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 746      &        restyp(itypi),i,restyp(itypj),j,
 747      &        epsi,sigm,chi1,chi2,chip1,chip2,
 748      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 749      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 750      &        evdwij
 751             endif
 752 C Calculate gradient components.
 753             e1=e1*eps1*eps2rt**2*eps3rt**2
 754             fac=-expon*(e1+evdwij)
 755             sigder=fac/sigsq
 756             fac=rrij*fac
 757 C Calculate radial part of the gradient
 758             gg(1)=xj*fac
 759             gg(2)=yj*fac
 760             gg(3)=zj*fac
 761 C Calculate the angular part of the gradient and sum add the contributions
 762 C to the appropriate components of the Cartesian gradient.
 763             call sc_grad
 764             endif
 765           enddo      ! j
 766         enddo        ! iint
 767       enddo          ! i
 768 c     stop
 769       return
 770       end
 771 C-----------------------------------------------------------------------------
 772       subroutine egb(evdw,evdw_t)
 773 C
 774 C This subroutine calculates the interaction energy of nonbonded side chains
 775 C assuming the Gay-Berne potential of interaction.
 776 C
 777       implicit real*8 (a-h,o-z)
 778       include 'DIMENSIONS'
 779       include 'DIMENSIONS.ZSCOPT'
 780       include "DIMENSIONS.COMPAR"
 781       include 'COMMON.GEO'
 782       include 'COMMON.VAR'
 783       include 'COMMON.LOCAL'
 784       include 'COMMON.CHAIN'
 785       include 'COMMON.DERIV'
 786       include 'COMMON.NAMES'
 787       include 'COMMON.INTERACT'
 788       include 'COMMON.ENEPS'
 789       include 'COMMON.IOUNITS'
 790       include 'COMMON.CALC'
 791       include 'COMMON.SBRIDGE'
 792       logical lprn
 793       common /srutu/icall
 794       integer icant
 795       external icant
 796       do i=1,210
 797         do j=1,2
 798           eneps_temp(j,i)=0.0d0
 799         enddo
 800       enddo
 801 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 802       evdw=0.0D0
 803       evdw_t=0.0d0
 804       lprn=.false.
 805 c      if (icall.gt.0) lprn=.true.
 806       ind=0
 807       do i=iatsc_s,iatsc_e
 808         itypi=iabs(itype(i))
 809         if (itypi.eq.ntyp1) cycle
 810         itypi1=iabs(itype(i+1))
 811         xi=c(1,nres+i)
 812         yi=c(2,nres+i)
 813         zi=c(3,nres+i)
 814         dxi=dc_norm(1,nres+i)
 815         dyi=dc_norm(2,nres+i)
 816         dzi=dc_norm(3,nres+i)
 817         dsci_inv=vbld_inv(i+nres)
 818 C
 819 C Calculate SC interaction energy.
 820 C
 821         do iint=1,nint_gr(i)
 822           do j=istart(i,iint),iend(i,iint)
 823             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 824               call dyn_ssbond_ene(i,j,evdwij)
 825               evdw=evdw+evdwij
 826 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 827 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
 828 C triple bond artifac removal
 829              do k=j+1,iend(i,iint)
 830 C search over all next residues
 831               if (dyn_ss_mask(k)) then
 832 C check if they are cysteins
 833 C              write(iout,*) 'k=',k
 834               call triple_ssbond_ene(i,j,k,evdwij)
 835 C call the energy function that removes the artifical triple disulfide
 836 C bond the soubroutine is located in ssMD.F
 837               evdw=evdw+evdwij
 838 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 839 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
 840               endif!dyn_ss_mask(k)
 841              enddo! k
 842             ELSE
 843             ind=ind+1
 844             itypj=iabs(itype(j))
 845             if (itypj.eq.ntyp1) cycle
 846             dscj_inv=vbld_inv(j+nres)
 847             sig0ij=sigma(itypi,itypj)
 848             chi1=chi(itypi,itypj)
 849             chi2=chi(itypj,itypi)
 850             chi12=chi1*chi2
 851             chip1=chip(itypi)
 852             chip2=chip(itypj)
 853             chip12=chip1*chip2
 854             alf1=alp(itypi)
 855             alf2=alp(itypj)
 856             alf12=0.5D0*(alf1+alf2)
 857 C For diagnostics only!!!
 858 c           chi1=0.0D0
 859 c           chi2=0.0D0
 860 c           chi12=0.0D0
 861 c           chip1=0.0D0
 862 c           chip2=0.0D0
 863 c           chip12=0.0D0
 864 c           alf1=0.0D0
 865 c           alf2=0.0D0
 866 c           alf12=0.0D0
 867             xj=c(1,nres+j)-xi
 868             yj=c(2,nres+j)-yi
 869             zj=c(3,nres+j)-zi
 870             dxj=dc_norm(1,nres+j)
 871             dyj=dc_norm(2,nres+j)
 872             dzj=dc_norm(3,nres+j)
 873 c            write (iout,*) i,j,xj,yj,zj
 874             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 875             rij=dsqrt(rrij)
 876 C Calculate angle-dependent terms of energy and contributions to their
 877 C derivatives.
 878             call sc_angular
 879             sigsq=1.0D0/sigsq
 880             sig=sig0ij*dsqrt(sigsq)
 881             rij_shift=1.0D0/rij-sig+sig0ij
 882 C I hate to put IF's in the loops, but here don't have another choice!!!!
 883             if (rij_shift.le.0.0D0) then
 884               evdw=1.0D20
 885               return
 886             endif
 887             sigder=-sig*sigsq
 888 c---------------------------------------------------------------
 889             rij_shift=1.0D0/rij_shift
 890             fac=rij_shift**expon
 891             e1=fac*fac*aa(itypi,itypj)
 892             e2=fac*bb(itypi,itypj)
 893             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 894             eps2der=evdwij*eps3rt
 895             eps3der=evdwij*eps2rt
 896             evdwij=evdwij*eps2rt*eps3rt
 897             if (bb(itypi,itypj).gt.0) then
 898               evdw=evdw+evdwij
 899             else
 900               evdw_t=evdw_t+evdwij
 901             endif
 902             ij=icant(itypi,itypj)
 903             aux=eps1*eps2rt**2*eps3rt**2
 904             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 905      &        /dabs(eps(itypi,itypj))
 906             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 907 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 908 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 909 c     &         aux*e2/eps(itypi,itypj)
 910 c            if (lprn) then
 911             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 912             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 913 #ifdef DEBUG
 914             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 915      &        restyp(itypi),i,restyp(itypj),j,
 916      &        epsi,sigm,chi1,chi2,chip1,chip2,
 917      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 918      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 919      &        evdwij
 920              write (iout,*) "partial sum", evdw, evdw_t
 921 #endif
 922 c            endif
 923             if (calc_grad) then
 924 C Calculate gradient components.
 925             e1=e1*eps1*eps2rt**2*eps3rt**2
 926             fac=-expon*(e1+evdwij)*rij_shift
 927             sigder=fac*sigder
 928             fac=rij*fac
 929 C Calculate the radial part of the gradient
 930             gg(1)=xj*fac
 931             gg(2)=yj*fac
 932             gg(3)=zj*fac
 933 C Calculate angular part of the gradient.
 934             call sc_grad
 935             endif
 936 C            write(iout,*)  "partial sum", evdw, evdw_t
 937             ENDIF    ! dyn_ss
 938           enddo      ! j
 939         enddo        ! iint
 940       enddo          ! i
 941       return
 942       end
 943 C-----------------------------------------------------------------------------
 944       subroutine egbv(evdw,evdw_t)
 945 C
 946 C This subroutine calculates the interaction energy of nonbonded side chains
 947 C assuming the Gay-Berne-Vorobjev potential of interaction.
 948 C
 949       implicit real*8 (a-h,o-z)
 950       include 'DIMENSIONS'
 951       include 'DIMENSIONS.ZSCOPT'
 952       include "DIMENSIONS.COMPAR"
 953       include 'COMMON.GEO'
 954       include 'COMMON.VAR'
 955       include 'COMMON.LOCAL'
 956       include 'COMMON.CHAIN'
 957       include 'COMMON.DERIV'
 958       include 'COMMON.NAMES'
 959       include 'COMMON.INTERACT'
 960       include 'COMMON.ENEPS'
 961       include 'COMMON.IOUNITS'
 962       include 'COMMON.CALC'
 963       common /srutu/ icall
 964       logical lprn
 965       integer icant
 966       external icant
 967       do i=1,210
 968         do j=1,2
 969           eneps_temp(j,i)=0.0d0
 970         enddo
 971       enddo
 972       evdw=0.0D0
 973       evdw_t=0.0d0
 974 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 975       evdw=0.0D0
 976       lprn=.false.
 977 c      if (icall.gt.0) lprn=.true.
 978       ind=0
 979       do i=iatsc_s,iatsc_e
 980         itypi=iabs(itype(i))
 981         if (itypi.eq.ntyp1) cycle
 982         itypi1=iabs(itype(i+1))
 983         xi=c(1,nres+i)
 984         yi=c(2,nres+i)
 985         zi=c(3,nres+i)
 986         dxi=dc_norm(1,nres+i)
 987         dyi=dc_norm(2,nres+i)
 988         dzi=dc_norm(3,nres+i)
 989         dsci_inv=vbld_inv(i+nres)
 990 C
 991 C Calculate SC interaction energy.
 992 C
 993         do iint=1,nint_gr(i)
 994           do j=istart(i,iint),iend(i,iint)
 995             ind=ind+1
 996             itypj=iabs(itype(j))
 997             if (itypj.eq.ntyp1) cycle
 998             dscj_inv=vbld_inv(j+nres)
 999             sig0ij=sigma(itypi,itypj)
1000             r0ij=r0(itypi,itypj)
1001             chi1=chi(itypi,itypj)
1002             chi2=chi(itypj,itypi)
1003             chi12=chi1*chi2
1004             chip1=chip(itypi)
1005             chip2=chip(itypj)
1006             chip12=chip1*chip2
1007             alf1=alp(itypi)
1008             alf2=alp(itypj)
1009             alf12=0.5D0*(alf1+alf2)
1010 C For diagnostics only!!!
1011 c           chi1=0.0D0
1012 c           chi2=0.0D0
1013 c           chi12=0.0D0
1014 c           chip1=0.0D0
1015 c           chip2=0.0D0
1016 c           chip12=0.0D0
1017 c           alf1=0.0D0
1018 c           alf2=0.0D0
1019 c           alf12=0.0D0
1020             xj=c(1,nres+j)-xi
1021             yj=c(2,nres+j)-yi
1022             zj=c(3,nres+j)-zi
1023             dxj=dc_norm(1,nres+j)
1024             dyj=dc_norm(2,nres+j)
1025             dzj=dc_norm(3,nres+j)
1026             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1027             rij=dsqrt(rrij)
1028 C Calculate angle-dependent terms of energy and contributions to their
1029 C derivatives.
1030             call sc_angular
1031             sigsq=1.0D0/sigsq
1032             sig=sig0ij*dsqrt(sigsq)
1033             rij_shift=1.0D0/rij-sig+r0ij
1034 C I hate to put IF's in the loops, but here don't have another choice!!!!
1035             if (rij_shift.le.0.0D0) then
1036               evdw=1.0D20
1037               return
1038             endif
1039             sigder=-sig*sigsq
1040 c---------------------------------------------------------------
1041             rij_shift=1.0D0/rij_shift
1042             fac=rij_shift**expon
1043             e1=fac*fac*aa(itypi,itypj)
1044             e2=fac*bb(itypi,itypj)
1045             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1046             eps2der=evdwij*eps3rt
1047             eps3der=evdwij*eps2rt
1048             fac_augm=rrij**expon
1049             e_augm=augm(itypi,itypj)*fac_augm
1050             evdwij=evdwij*eps2rt*eps3rt
1051             if (bb(itypi,itypj).gt.0.0d0) then
1052               evdw=evdw+evdwij+e_augm
1053             else
1054               evdw_t=evdw_t+evdwij+e_augm
1055             endif
1056             ij=icant(itypi,itypj)
1057             aux=eps1*eps2rt**2*eps3rt**2
1058             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1059      &        /dabs(eps(itypi,itypj))
1060             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1061 c            eneps_temp(ij)=eneps_temp(ij)
1062 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1063 c            if (lprn) then
1064 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1065 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1066 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1067 c     &        restyp(itypi),i,restyp(itypj),j,
1068 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1069 c     &        chi1,chi2,chip1,chip2,
1070 c     &        eps1,eps2rt**2,eps3rt**2,
1071 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1072 c     &        evdwij+e_augm
1073 c            endif
1074             if (calc_grad) then
1075 C Calculate gradient components.
1076             e1=e1*eps1*eps2rt**2*eps3rt**2
1077             fac=-expon*(e1+evdwij)*rij_shift
1078             sigder=fac*sigder
1079             fac=rij*fac-2*expon*rrij*e_augm
1080 C Calculate the radial part of the gradient
1081             gg(1)=xj*fac
1082             gg(2)=yj*fac
1083             gg(3)=zj*fac
1084 C Calculate angular part of the gradient.
1085             call sc_grad
1086             endif
1087           enddo      ! j
1088         enddo        ! iint
1089       enddo          ! i
1090       return
1091       end
1092 C-----------------------------------------------------------------------------
1093       subroutine sc_angular
1094 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1095 C om12. Called by ebp, egb, and egbv.
1096       implicit none
1097       include 'COMMON.CALC'
1098       erij(1)=xj*rij
1099       erij(2)=yj*rij
1100       erij(3)=zj*rij
1101       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1102       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1103       om12=dxi*dxj+dyi*dyj+dzi*dzj
1104       chiom12=chi12*om12
1105 C Calculate eps1(om12) and its derivative in om12
1106       faceps1=1.0D0-om12*chiom12
1107       faceps1_inv=1.0D0/faceps1
1108       eps1=dsqrt(faceps1_inv)
1109 C Following variable is eps1*deps1/dom12
1110       eps1_om12=faceps1_inv*chiom12
1111 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1112 C and om12.
1113       om1om2=om1*om2
1114       chiom1=chi1*om1
1115       chiom2=chi2*om2
1116       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1117       sigsq=1.0D0-facsig*faceps1_inv
1118       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1119       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1120       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1121 C Calculate eps2 and its derivatives in om1, om2, and om12.
1122       chipom1=chip1*om1
1123       chipom2=chip2*om2
1124       chipom12=chip12*om12
1125       facp=1.0D0-om12*chipom12
1126       facp_inv=1.0D0/facp
1127       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1128 C Following variable is the square root of eps2
1129       eps2rt=1.0D0-facp1*facp_inv
1130 C Following three variables are the derivatives of the square root of eps
1131 C in om1, om2, and om12.
1132       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1133       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1134       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1135 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1136       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1137 C Calculate whole angle-dependent part of epsilon and contributions
1138 C to its derivatives
1139       return
1140       end
1141 C----------------------------------------------------------------------------
1142       subroutine sc_grad
1143       implicit real*8 (a-h,o-z)
1144       include 'DIMENSIONS'
1145       include 'DIMENSIONS.ZSCOPT'
1146       include 'COMMON.CHAIN'
1147       include 'COMMON.DERIV'
1148       include 'COMMON.CALC'
1149       double precision dcosom1(3),dcosom2(3)
1150       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1151       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1152       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1153      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1154       do k=1,3
1155         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1156         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1157       enddo
1158       do k=1,3
1159         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1160       enddo
1161       do k=1,3
1162         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1163      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1164      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1165         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1166      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1167      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1168       enddo
1169 C
1170 C Calculate the components of the gradient in DC and X
1171 C
1172       do k=i,j-1
1173         do l=1,3
1174           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1175         enddo
1176       enddo
1177       return
1178       end
1179 c------------------------------------------------------------------------------
1180       subroutine vec_and_deriv
1181       implicit real*8 (a-h,o-z)
1182       include 'DIMENSIONS'
1183       include 'DIMENSIONS.ZSCOPT'
1184       include 'COMMON.IOUNITS'
1185       include 'COMMON.GEO'
1186       include 'COMMON.VAR'
1187       include 'COMMON.LOCAL'
1188       include 'COMMON.CHAIN'
1189       include 'COMMON.VECTORS'
1190       include 'COMMON.DERIV'
1191       include 'COMMON.INTERACT'
1192       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1193 C Compute the local reference systems. For reference system (i), the
1194 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1195 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1196       do i=1,nres-1
1197 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1198           if (i.eq.nres-1) then
1199 C Case of the last full residue
1200 C Compute the Z-axis
1201             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1202             costh=dcos(pi-theta(nres))
1203             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1204             do k=1,3
1205               uz(k,i)=fac*uz(k,i)
1206             enddo
1207             if (calc_grad) then
1208 C Compute the derivatives of uz
1209             uzder(1,1,1)= 0.0d0
1210             uzder(2,1,1)=-dc_norm(3,i-1)
1211             uzder(3,1,1)= dc_norm(2,i-1)
1212             uzder(1,2,1)= dc_norm(3,i-1)
1213             uzder(2,2,1)= 0.0d0
1214             uzder(3,2,1)=-dc_norm(1,i-1)
1215             uzder(1,3,1)=-dc_norm(2,i-1)
1216             uzder(2,3,1)= dc_norm(1,i-1)
1217             uzder(3,3,1)= 0.0d0
1218             uzder(1,1,2)= 0.0d0
1219             uzder(2,1,2)= dc_norm(3,i)
1220             uzder(3,1,2)=-dc_norm(2,i)
1221             uzder(1,2,2)=-dc_norm(3,i)
1222             uzder(2,2,2)= 0.0d0
1223             uzder(3,2,2)= dc_norm(1,i)
1224             uzder(1,3,2)= dc_norm(2,i)
1225             uzder(2,3,2)=-dc_norm(1,i)
1226             uzder(3,3,2)= 0.0d0
1227             endif
1228 C Compute the Y-axis
1229             facy=fac
1230             do k=1,3
1231               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1232             enddo
1233             if (calc_grad) then
1234 C Compute the derivatives of uy
1235             do j=1,3
1236               do k=1,3
1237                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1238      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1239                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1240               enddo
1241               uyder(j,j,1)=uyder(j,j,1)-costh
1242               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1243             enddo
1244             do j=1,2
1245               do k=1,3
1246                 do l=1,3
1247                   uygrad(l,k,j,i)=uyder(l,k,j)
1248                   uzgrad(l,k,j,i)=uzder(l,k,j)
1249                 enddo
1250               enddo
1251             enddo
1252             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1253             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1254             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1255             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1256             endif
1257           else
1258 C Other residues
1259 C Compute the Z-axis
1260             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1261             costh=dcos(pi-theta(i+2))
1262             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1263             do k=1,3
1264               uz(k,i)=fac*uz(k,i)
1265             enddo
1266             if (calc_grad) then
1267 C Compute the derivatives of uz
1268             uzder(1,1,1)= 0.0d0
1269             uzder(2,1,1)=-dc_norm(3,i+1)
1270             uzder(3,1,1)= dc_norm(2,i+1)
1271             uzder(1,2,1)= dc_norm(3,i+1)
1272             uzder(2,2,1)= 0.0d0
1273             uzder(3,2,1)=-dc_norm(1,i+1)
1274             uzder(1,3,1)=-dc_norm(2,i+1)
1275             uzder(2,3,1)= dc_norm(1,i+1)
1276             uzder(3,3,1)= 0.0d0
1277             uzder(1,1,2)= 0.0d0
1278             uzder(2,1,2)= dc_norm(3,i)
1279             uzder(3,1,2)=-dc_norm(2,i)
1280             uzder(1,2,2)=-dc_norm(3,i)
1281             uzder(2,2,2)= 0.0d0
1282             uzder(3,2,2)= dc_norm(1,i)
1283             uzder(1,3,2)= dc_norm(2,i)
1284             uzder(2,3,2)=-dc_norm(1,i)
1285             uzder(3,3,2)= 0.0d0
1286             endif
1287 C Compute the Y-axis
1288             facy=fac
1289             do k=1,3
1290               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1291             enddo
1292             if (calc_grad) then
1293 C Compute the derivatives of uy
1294             do j=1,3
1295               do k=1,3
1296                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1297      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1298                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1299               enddo
1300               uyder(j,j,1)=uyder(j,j,1)-costh
1301               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1302             enddo
1303             do j=1,2
1304               do k=1,3
1305                 do l=1,3
1306                   uygrad(l,k,j,i)=uyder(l,k,j)
1307                   uzgrad(l,k,j,i)=uzder(l,k,j)
1308                 enddo
1309               enddo
1310             enddo
1311             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1312             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1313             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1314             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1315           endif
1316           endif
1317       enddo
1318       if (calc_grad) then
1319       do i=1,nres-1
1320         vbld_inv_temp(1)=vbld_inv(i+1)
1321         if (i.lt.nres-1) then
1322           vbld_inv_temp(2)=vbld_inv(i+2)
1323         else
1324           vbld_inv_temp(2)=vbld_inv(i)
1325         endif
1326         do j=1,2
1327           do k=1,3
1328             do l=1,3
1329               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1330               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1331             enddo
1332           enddo
1333         enddo
1334       enddo
1335       endif
1336       return
1337       end
1338 C-----------------------------------------------------------------------------
1339       subroutine vec_and_deriv_test
1340       implicit real*8 (a-h,o-z)
1341       include 'DIMENSIONS'
1342       include 'DIMENSIONS.ZSCOPT'
1343       include 'COMMON.IOUNITS'
1344       include 'COMMON.GEO'
1345       include 'COMMON.VAR'
1346       include 'COMMON.LOCAL'
1347       include 'COMMON.CHAIN'
1348       include 'COMMON.VECTORS'
1349       dimension uyder(3,3,2),uzder(3,3,2)
1350 C Compute the local reference systems. For reference system (i), the
1351 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1352 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1353       do i=1,nres-1
1354           if (i.eq.nres-1) then
1355 C Case of the last full residue
1356 C Compute the Z-axis
1357             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1358             costh=dcos(pi-theta(nres))
1359             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1360 c            write (iout,*) 'fac',fac,
1361 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1362             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1363             do k=1,3
1364               uz(k,i)=fac*uz(k,i)
1365             enddo
1366 C Compute the derivatives of uz
1367             uzder(1,1,1)= 0.0d0
1368             uzder(2,1,1)=-dc_norm(3,i-1)
1369             uzder(3,1,1)= dc_norm(2,i-1)
1370             uzder(1,2,1)= dc_norm(3,i-1)
1371             uzder(2,2,1)= 0.0d0
1372             uzder(3,2,1)=-dc_norm(1,i-1)
1373             uzder(1,3,1)=-dc_norm(2,i-1)
1374             uzder(2,3,1)= dc_norm(1,i-1)
1375             uzder(3,3,1)= 0.0d0
1376             uzder(1,1,2)= 0.0d0
1377             uzder(2,1,2)= dc_norm(3,i)
1378             uzder(3,1,2)=-dc_norm(2,i)
1379             uzder(1,2,2)=-dc_norm(3,i)
1380             uzder(2,2,2)= 0.0d0
1381             uzder(3,2,2)= dc_norm(1,i)
1382             uzder(1,3,2)= dc_norm(2,i)
1383             uzder(2,3,2)=-dc_norm(1,i)
1384             uzder(3,3,2)= 0.0d0
1385 C Compute the Y-axis
1386             do k=1,3
1387               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1388             enddo
1389             facy=fac
1390             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1391      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1392      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1393             do k=1,3
1394 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1395               uy(k,i)=
1396 c     &        facy*(
1397      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1398      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1399 c     &        )
1400             enddo
1401 c            write (iout,*) 'facy',facy,
1402 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1403             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1404             do k=1,3
1405               uy(k,i)=facy*uy(k,i)
1406             enddo
1407 C Compute the derivatives of uy
1408             do j=1,3
1409               do k=1,3
1410                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1411      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1412                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1413               enddo
1414 c              uyder(j,j,1)=uyder(j,j,1)-costh
1415 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1416               uyder(j,j,1)=uyder(j,j,1)
1417      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1418               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1419      &          +uyder(j,j,2)
1420             enddo
1421             do j=1,2
1422               do k=1,3
1423                 do l=1,3
1424                   uygrad(l,k,j,i)=uyder(l,k,j)
1425                   uzgrad(l,k,j,i)=uzder(l,k,j)
1426                 enddo
1427               enddo
1428             enddo
1429             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1430             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1431             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1432             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1433           else
1434 C Other residues
1435 C Compute the Z-axis
1436             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1437             costh=dcos(pi-theta(i+2))
1438             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1439             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1440             do k=1,3
1441               uz(k,i)=fac*uz(k,i)
1442             enddo
1443 C Compute the derivatives of uz
1444             uzder(1,1,1)= 0.0d0
1445             uzder(2,1,1)=-dc_norm(3,i+1)
1446             uzder(3,1,1)= dc_norm(2,i+1)
1447             uzder(1,2,1)= dc_norm(3,i+1)
1448             uzder(2,2,1)= 0.0d0
1449             uzder(3,2,1)=-dc_norm(1,i+1)
1450             uzder(1,3,1)=-dc_norm(2,i+1)
1451             uzder(2,3,1)= dc_norm(1,i+1)
1452             uzder(3,3,1)= 0.0d0
1453             uzder(1,1,2)= 0.0d0
1454             uzder(2,1,2)= dc_norm(3,i)
1455             uzder(3,1,2)=-dc_norm(2,i)
1456             uzder(1,2,2)=-dc_norm(3,i)
1457             uzder(2,2,2)= 0.0d0
1458             uzder(3,2,2)= dc_norm(1,i)
1459             uzder(1,3,2)= dc_norm(2,i)
1460             uzder(2,3,2)=-dc_norm(1,i)
1461             uzder(3,3,2)= 0.0d0
1462 C Compute the Y-axis
1463             facy=fac
1464             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1465      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1466      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1467             do k=1,3
1468 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1469               uy(k,i)=
1470 c     &        facy*(
1471      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1472      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1473 c     &        )
1474             enddo
1475 c            write (iout,*) 'facy',facy,
1476 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1477             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1478             do k=1,3
1479               uy(k,i)=facy*uy(k,i)
1480             enddo
1481 C Compute the derivatives of uy
1482             do j=1,3
1483               do k=1,3
1484                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1485      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1486                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1487               enddo
1488 c              uyder(j,j,1)=uyder(j,j,1)-costh
1489 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1490               uyder(j,j,1)=uyder(j,j,1)
1491      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1492               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1493      &          +uyder(j,j,2)
1494             enddo
1495             do j=1,2
1496               do k=1,3
1497                 do l=1,3
1498                   uygrad(l,k,j,i)=uyder(l,k,j)
1499                   uzgrad(l,k,j,i)=uzder(l,k,j)
1500                 enddo
1501               enddo
1502             enddo
1503             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1504             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1505             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1506             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1507           endif
1508       enddo
1509       do i=1,nres-1
1510         do j=1,2
1511           do k=1,3
1512             do l=1,3
1513               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1514               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1515             enddo
1516           enddo
1517         enddo
1518       enddo
1519       return
1520       end
1521 C-----------------------------------------------------------------------------
1522       subroutine check_vecgrad
1523       implicit real*8 (a-h,o-z)
1524       include 'DIMENSIONS'
1525       include 'DIMENSIONS.ZSCOPT'
1526       include 'COMMON.IOUNITS'
1527       include 'COMMON.GEO'
1528       include 'COMMON.VAR'
1529       include 'COMMON.LOCAL'
1530       include 'COMMON.CHAIN'
1531       include 'COMMON.VECTORS'
1532       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1533       dimension uyt(3,maxres),uzt(3,maxres)
1534       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1535       double precision delta /1.0d-7/
1536       call vec_and_deriv
1537 cd      do i=1,nres
1538 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1539 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1540 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1541 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1542 cd     &     (dc_norm(if90,i),if90=1,3)
1543 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1544 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1545 cd          write(iout,'(a)')
1546 cd      enddo
1547       do i=1,nres
1548         do j=1,2
1549           do k=1,3
1550             do l=1,3
1551               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1552               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1553             enddo
1554           enddo
1555         enddo
1556       enddo
1557       call vec_and_deriv
1558       do i=1,nres
1559         do j=1,3
1560           uyt(j,i)=uy(j,i)
1561           uzt(j,i)=uz(j,i)
1562         enddo
1563       enddo
1564       do i=1,nres
1565 cd        write (iout,*) 'i=',i
1566         do k=1,3
1567           erij(k)=dc_norm(k,i)
1568         enddo
1569         do j=1,3
1570           do k=1,3
1571             dc_norm(k,i)=erij(k)
1572           enddo
1573           dc_norm(j,i)=dc_norm(j,i)+delta
1574 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1575 c          do k=1,3
1576 c            dc_norm(k,i)=dc_norm(k,i)/fac
1577 c          enddo
1578 c          write (iout,*) (dc_norm(k,i),k=1,3)
1579 c          write (iout,*) (erij(k),k=1,3)
1580           call vec_and_deriv
1581           do k=1,3
1582             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1583             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1584             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1585             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1586           enddo
1587 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1588 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1589 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1590         enddo
1591         do k=1,3
1592           dc_norm(k,i)=erij(k)
1593         enddo
1594 cd        do k=1,3
1595 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1596 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1597 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1598 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1599 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1600 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1601 cd          write (iout,'(a)')
1602 cd        enddo
1603       enddo
1604       return
1605       end
1606 C--------------------------------------------------------------------------
1607       subroutine set_matrices
1608       implicit real*8 (a-h,o-z)
1609       include 'DIMENSIONS'
1610       include 'DIMENSIONS.ZSCOPT'
1611       include 'COMMON.IOUNITS'
1612       include 'COMMON.GEO'
1613       include 'COMMON.VAR'
1614       include 'COMMON.LOCAL'
1615       include 'COMMON.CHAIN'
1616       include 'COMMON.DERIV'
1617       include 'COMMON.INTERACT'
1618       include 'COMMON.CONTACTS'
1619       include 'COMMON.TORSION'
1620       include 'COMMON.VECTORS'
1621       include 'COMMON.FFIELD'
1622       double precision auxvec(2),auxmat(2,2)
1623 C
1624 C Compute the virtual-bond-torsional-angle dependent quantities needed
1625 C to calculate the el-loc multibody terms of various order.
1626 C
1627       do i=3,nres+1
1628         if (i .lt. nres+1) then
1629           sin1=dsin(phi(i))
1630           cos1=dcos(phi(i))
1631           sintab(i-2)=sin1
1632           costab(i-2)=cos1
1633           obrot(1,i-2)=cos1
1634           obrot(2,i-2)=sin1
1635           sin2=dsin(2*phi(i))
1636           cos2=dcos(2*phi(i))
1637           sintab2(i-2)=sin2
1638           costab2(i-2)=cos2
1639           obrot2(1,i-2)=cos2
1640           obrot2(2,i-2)=sin2
1641           Ug(1,1,i-2)=-cos1
1642           Ug(1,2,i-2)=-sin1
1643           Ug(2,1,i-2)=-sin1
1644           Ug(2,2,i-2)= cos1
1645           Ug2(1,1,i-2)=-cos2
1646           Ug2(1,2,i-2)=-sin2
1647           Ug2(2,1,i-2)=-sin2
1648           Ug2(2,2,i-2)= cos2
1649         else
1650           costab(i-2)=1.0d0
1651           sintab(i-2)=0.0d0
1652           obrot(1,i-2)=1.0d0
1653           obrot(2,i-2)=0.0d0
1654           obrot2(1,i-2)=0.0d0
1655           obrot2(2,i-2)=0.0d0
1656           Ug(1,1,i-2)=1.0d0
1657           Ug(1,2,i-2)=0.0d0
1658           Ug(2,1,i-2)=0.0d0
1659           Ug(2,2,i-2)=1.0d0
1660           Ug2(1,1,i-2)=0.0d0
1661           Ug2(1,2,i-2)=0.0d0
1662           Ug2(2,1,i-2)=0.0d0
1663           Ug2(2,2,i-2)=0.0d0
1664         endif
1665         if (i .gt. 3 .and. i .lt. nres+1) then
1666           obrot_der(1,i-2)=-sin1
1667           obrot_der(2,i-2)= cos1
1668           Ugder(1,1,i-2)= sin1
1669           Ugder(1,2,i-2)=-cos1
1670           Ugder(2,1,i-2)=-cos1
1671           Ugder(2,2,i-2)=-sin1
1672           dwacos2=cos2+cos2
1673           dwasin2=sin2+sin2
1674           obrot2_der(1,i-2)=-dwasin2
1675           obrot2_der(2,i-2)= dwacos2
1676           Ug2der(1,1,i-2)= dwasin2
1677           Ug2der(1,2,i-2)=-dwacos2
1678           Ug2der(2,1,i-2)=-dwacos2
1679           Ug2der(2,2,i-2)=-dwasin2
1680         else
1681           obrot_der(1,i-2)=0.0d0
1682           obrot_der(2,i-2)=0.0d0
1683           Ugder(1,1,i-2)=0.0d0
1684           Ugder(1,2,i-2)=0.0d0
1685           Ugder(2,1,i-2)=0.0d0
1686           Ugder(2,2,i-2)=0.0d0
1687           obrot2_der(1,i-2)=0.0d0
1688           obrot2_der(2,i-2)=0.0d0
1689           Ug2der(1,1,i-2)=0.0d0
1690           Ug2der(1,2,i-2)=0.0d0
1691           Ug2der(2,1,i-2)=0.0d0
1692           Ug2der(2,2,i-2)=0.0d0
1693         endif
1694         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1695           if (itype(i-2).le.ntyp) then
1696             iti = itortyp(itype(i-2))
1697           else
1698             iti=ntortyp+1
1699           endif
1700         else
1701           iti=ntortyp+1
1702         endif
1703         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1704           if (itype(i-1).le.ntyp) then
1705             iti1 = itortyp(itype(i-1))
1706           else
1707             iti1=ntortyp+1
1708           endif
1709         else
1710           iti1=ntortyp+1
1711         endif
1712 cd        write (iout,*) '*******i',i,' iti1',iti
1713 cd        write (iout,*) 'b1',b1(:,iti)
1714 cd        write (iout,*) 'b2',b2(:,iti)
1715 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1716 c        print *,"itilde1 i iti iti1",i,iti,iti1
1717         if (i .gt. iatel_s+2) then
1718           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1719           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1720           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1721           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1722           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1723           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1724           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1725         else
1726           do k=1,2
1727             Ub2(k,i-2)=0.0d0
1728             Ctobr(k,i-2)=0.0d0
1729             Dtobr2(k,i-2)=0.0d0
1730             do l=1,2
1731               EUg(l,k,i-2)=0.0d0
1732               CUg(l,k,i-2)=0.0d0
1733               DUg(l,k,i-2)=0.0d0
1734               DtUg2(l,k,i-2)=0.0d0
1735             enddo
1736           enddo
1737         endif
1738 c        print *,"itilde2 i iti iti1",i,iti,iti1
1739         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1740         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1741         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1742         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1743         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1744         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1745         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1746 c        print *,"itilde3 i iti iti1",i,iti,iti1
1747         do k=1,2
1748           muder(k,i-2)=Ub2der(k,i-2)
1749         enddo
1750         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1751           if (itype(i-1).le.ntyp) then
1752             iti1 = itortyp(itype(i-1))
1753           else
1754             iti1=ntortyp+1
1755           endif
1756         else
1757           iti1=ntortyp+1
1758         endif
1759         do k=1,2
1760           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1761         enddo
1762 C Vectors and matrices dependent on a single virtual-bond dihedral.
1763         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1764         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1765         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1766         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1767         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1768         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1769         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1770         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1771         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1772 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1773 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1774       enddo
1775 C Matrices dependent on two consecutive virtual-bond dihedrals.
1776 C The order of matrices is from left to right.
1777       do i=2,nres-1
1778         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1779         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1780         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1781         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1782         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1783         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1784         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1785         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1786       enddo
1787 cd      do i=1,nres
1788 cd        iti = itortyp(itype(i))
1789 cd        write (iout,*) i
1790 cd        do j=1,2
1791 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1792 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1793 cd        enddo
1794 cd      enddo
1795       return
1796       end
1797 C--------------------------------------------------------------------------
1798       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1799 C
1800 C This subroutine calculates the average interaction energy and its gradient
1801 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1802 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1803 C The potential depends both on the distance of peptide-group centers and on
1804 C the orientation of the CA-CA virtual bonds.
1805 C
1806       implicit real*8 (a-h,o-z)
1807       include 'DIMENSIONS'
1808       include 'DIMENSIONS.ZSCOPT'
1809       include 'COMMON.CONTROL'
1810       include 'COMMON.IOUNITS'
1811       include 'COMMON.GEO'
1812       include 'COMMON.VAR'
1813       include 'COMMON.LOCAL'
1814       include 'COMMON.CHAIN'
1815       include 'COMMON.DERIV'
1816       include 'COMMON.INTERACT'
1817       include 'COMMON.CONTACTS'
1818       include 'COMMON.TORSION'
1819       include 'COMMON.VECTORS'
1820       include 'COMMON.FFIELD'
1821       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1822      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1823       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1824      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1825       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1826 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1827       double precision scal_el /0.5d0/
1828 C 12/13/98
1829 C 13-go grudnia roku pamietnego...
1830       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1831      &                   0.0d0,1.0d0,0.0d0,
1832      &                   0.0d0,0.0d0,1.0d0/
1833 cd      write(iout,*) 'In EELEC'
1834 cd      do i=1,nloctyp
1835 cd        write(iout,*) 'Type',i
1836 cd        write(iout,*) 'B1',B1(:,i)
1837 cd        write(iout,*) 'B2',B2(:,i)
1838 cd        write(iout,*) 'CC',CC(:,:,i)
1839 cd        write(iout,*) 'DD',DD(:,:,i)
1840 cd        write(iout,*) 'EE',EE(:,:,i)
1841 cd      enddo
1842 cd      call check_vecgrad
1843 cd      stop
1844       if (icheckgrad.eq.1) then
1845         do i=1,nres-1
1846           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1847           do k=1,3
1848             dc_norm(k,i)=dc(k,i)*fac
1849           enddo
1850 c          write (iout,*) 'i',i,' fac',fac
1851         enddo
1852       endif
1853       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1854      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1855      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1856 cd      if (wel_loc.gt.0.0d0) then
1857         if (icheckgrad.eq.1) then
1858         call vec_and_deriv_test
1859         else
1860         call vec_and_deriv
1861         endif
1862         call set_matrices
1863       endif
1864 cd      do i=1,nres-1
1865 cd        write (iout,*) 'i=',i
1866 cd        do k=1,3
1867 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1868 cd        enddo
1869 cd        do k=1,3
1870 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1871 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1872 cd        enddo
1873 cd      enddo
1874       num_conti_hb=0
1875       ees=0.0D0
1876       evdw1=0.0D0
1877       eel_loc=0.0d0
1878       eello_turn3=0.0d0
1879       eello_turn4=0.0d0
1880       ind=0
1881       do i=1,nres
1882         num_cont_hb(i)=0
1883       enddo
1884 cd      print '(a)','Enter EELEC'
1885 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1886       do i=1,nres
1887         gel_loc_loc(i)=0.0d0
1888         gcorr_loc(i)=0.0d0
1889       enddo
1890       do i=iatel_s,iatel_e
1891         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1892         if (itel(i).eq.0) goto 1215
1893         dxi=dc(1,i)
1894         dyi=dc(2,i)
1895         dzi=dc(3,i)
1896         dx_normi=dc_norm(1,i)
1897         dy_normi=dc_norm(2,i)
1898         dz_normi=dc_norm(3,i)
1899         xmedi=c(1,i)+0.5d0*dxi
1900         ymedi=c(2,i)+0.5d0*dyi
1901         zmedi=c(3,i)+0.5d0*dzi
1902         num_conti=0
1903 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1904         do j=ielstart(i),ielend(i)
1905           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1906           if (itel(j).eq.0) goto 1216
1907           ind=ind+1
1908           iteli=itel(i)
1909           itelj=itel(j)
1910           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1911           aaa=app(iteli,itelj)
1912           bbb=bpp(iteli,itelj)
1913 C Diagnostics only!!!
1914 c         aaa=0.0D0
1915 c         bbb=0.0D0
1916 c         ael6i=0.0D0
1917 c         ael3i=0.0D0
1918 C End diagnostics
1919           ael6i=ael6(iteli,itelj)
1920           ael3i=ael3(iteli,itelj)
1921           dxj=dc(1,j)
1922           dyj=dc(2,j)
1923           dzj=dc(3,j)
1924           dx_normj=dc_norm(1,j)
1925           dy_normj=dc_norm(2,j)
1926           dz_normj=dc_norm(3,j)
1927           xj=c(1,j)+0.5D0*dxj-xmedi
1928           yj=c(2,j)+0.5D0*dyj-ymedi
1929           zj=c(3,j)+0.5D0*dzj-zmedi
1930           rij=xj*xj+yj*yj+zj*zj
1931           rrmij=1.0D0/rij
1932           rij=dsqrt(rij)
1933           rmij=1.0D0/rij
1934           r3ij=rrmij*rmij
1935           r6ij=r3ij*r3ij
1936           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1937           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1938           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1939           fac=cosa-3.0D0*cosb*cosg
1940           ev1=aaa*r6ij*r6ij
1941 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1942           if (j.eq.i+2) ev1=scal_el*ev1
1943           ev2=bbb*r6ij
1944           fac3=ael6i*r6ij
1945           fac4=ael3i*r3ij
1946           evdwij=ev1+ev2
1947           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1948           el2=fac4*fac
1949           eesij=el1+el2
1950 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1951 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1952           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1953           ees=ees+eesij
1954           evdw1=evdw1+evdwij
1955 c             write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
1956 c     &'evdw1',i,j,evdwij
1957 c     &,iteli,itelj,aaa,evdw1
1958
1959 c              write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
1960 c          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1961 c     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1962 c     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1963 c     &      xmedi,ymedi,zmedi,xj,yj,zj
1964 C
1965 C Calculate contributions to the Cartesian gradient.
1966 C
1967 #ifdef SPLITELE
1968           facvdw=-6*rrmij*(ev1+evdwij)
1969           facel=-3*rrmij*(el1+eesij)
1970           fac1=fac
1971           erij(1)=xj*rmij
1972           erij(2)=yj*rmij
1973           erij(3)=zj*rmij
1974           if (calc_grad) then
1975 *
1976 * Radial derivatives. First process both termini of the fragment (i,j)
1977 *
1978           ggg(1)=facel*xj
1979           ggg(2)=facel*yj
1980           ggg(3)=facel*zj
1981           do k=1,3
1982             ghalf=0.5D0*ggg(k)
1983             gelc(k,i)=gelc(k,i)+ghalf
1984             gelc(k,j)=gelc(k,j)+ghalf
1985           enddo
1986 *
1987 * Loop over residues i+1 thru j-1.
1988 *
1989           do k=i+1,j-1
1990             do l=1,3
1991               gelc(l,k)=gelc(l,k)+ggg(l)
1992             enddo
1993           enddo
1994           ggg(1)=facvdw*xj
1995           ggg(2)=facvdw*yj
1996           ggg(3)=facvdw*zj
1997           do k=1,3
1998             ghalf=0.5D0*ggg(k)
1999             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2000             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2001           enddo
2002 *
2003 * Loop over residues i+1 thru j-1.
2004 *
2005           do k=i+1,j-1
2006             do l=1,3
2007               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2008             enddo
2009           enddo
2010 #else
2011           facvdw=ev1+evdwij
2012           facel=el1+eesij
2013           fac1=fac
2014           fac=-3*rrmij*(facvdw+facvdw+facel)
2015           erij(1)=xj*rmij
2016           erij(2)=yj*rmij
2017           erij(3)=zj*rmij
2018           if (calc_grad) then
2019 *
2020 * Radial derivatives. First process both termini of the fragment (i,j)
2021 *
2022           ggg(1)=fac*xj
2023           ggg(2)=fac*yj
2024           ggg(3)=fac*zj
2025           do k=1,3
2026             ghalf=0.5D0*ggg(k)
2027             gelc(k,i)=gelc(k,i)+ghalf
2028             gelc(k,j)=gelc(k,j)+ghalf
2029           enddo
2030 *
2031 * Loop over residues i+1 thru j-1.
2032 *
2033           do k=i+1,j-1
2034             do l=1,3
2035               gelc(l,k)=gelc(l,k)+ggg(l)
2036             enddo
2037           enddo
2038 #endif
2039 *
2040 * Angular part
2041 *
2042           ecosa=2.0D0*fac3*fac1+fac4
2043           fac4=-3.0D0*fac4
2044           fac3=-6.0D0*fac3
2045           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2046           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2047           do k=1,3
2048             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2049             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2050           enddo
2051 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2052 cd   &          (dcosg(k),k=1,3)
2053           do k=1,3
2054             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2055           enddo
2056           do k=1,3
2057             ghalf=0.5D0*ggg(k)
2058             gelc(k,i)=gelc(k,i)+ghalf
2059      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2060      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2061             gelc(k,j)=gelc(k,j)+ghalf
2062      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2063      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2064           enddo
2065           do k=i+1,j-1
2066             do l=1,3
2067               gelc(l,k)=gelc(l,k)+ggg(l)
2068             enddo
2069           enddo
2070           endif
2071
2072           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2073      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2074      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2075 C
2076 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2077 C   energy of a peptide unit is assumed in the form of a second-order
2078 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2079 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2080 C   are computed for EVERY pair of non-contiguous peptide groups.
2081 C
2082           if (j.lt.nres-1) then
2083             j1=j+1
2084             j2=j-1
2085           else
2086             j1=j-1
2087             j2=j-2
2088           endif
2089           kkk=0
2090           do k=1,2
2091             do l=1,2
2092               kkk=kkk+1
2093               muij(kkk)=mu(k,i)*mu(l,j)
2094             enddo
2095           enddo
2096 cd         write (iout,*) 'EELEC: i',i,' j',j
2097 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2098 cd          write(iout,*) 'muij',muij
2099           ury=scalar(uy(1,i),erij)
2100           urz=scalar(uz(1,i),erij)
2101           vry=scalar(uy(1,j),erij)
2102           vrz=scalar(uz(1,j),erij)
2103           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2104           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2105           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2106           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2107 C For diagnostics only
2108 cd          a22=1.0d0
2109 cd          a23=1.0d0
2110 cd          a32=1.0d0
2111 cd          a33=1.0d0
2112           fac=dsqrt(-ael6i)*r3ij
2113 cd          write (2,*) 'fac=',fac
2114 C For diagnostics only
2115 cd          fac=1.0d0
2116           a22=a22*fac
2117           a23=a23*fac
2118           a32=a32*fac
2119           a33=a33*fac
2120 cd          write (iout,'(4i5,4f10.5)')
2121 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2122 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2123 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2124 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2125 cd          write (iout,'(4f10.5)')
2126 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2127 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2128 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2129 cd           write (iout,'(2i3,9f10.5/)') i,j,
2130 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2131           if (calc_grad) then
2132 C Derivatives of the elements of A in virtual-bond vectors
2133           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2134 cd          do k=1,3
2135 cd            do l=1,3
2136 cd              erder(k,l)=0.0d0
2137 cd            enddo
2138 cd          enddo
2139           do k=1,3
2140             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2141             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2142             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2143             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2144             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2145             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2146             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2147             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2148             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2149             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2150             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2151             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2152           enddo
2153 cd          do k=1,3
2154 cd            do l=1,3
2155 cd              uryg(k,l)=0.0d0
2156 cd              urzg(k,l)=0.0d0
2157 cd              vryg(k,l)=0.0d0
2158 cd              vrzg(k,l)=0.0d0
2159 cd            enddo
2160 cd          enddo
2161 C Compute radial contributions to the gradient
2162           facr=-3.0d0*rrmij
2163           a22der=a22*facr
2164           a23der=a23*facr
2165           a32der=a32*facr
2166           a33der=a33*facr
2167 cd          a22der=0.0d0
2168 cd          a23der=0.0d0
2169 cd          a32der=0.0d0
2170 cd          a33der=0.0d0
2171           agg(1,1)=a22der*xj
2172           agg(2,1)=a22der*yj
2173           agg(3,1)=a22der*zj
2174           agg(1,2)=a23der*xj
2175           agg(2,2)=a23der*yj
2176           agg(3,2)=a23der*zj
2177           agg(1,3)=a32der*xj
2178           agg(2,3)=a32der*yj
2179           agg(3,3)=a32der*zj
2180           agg(1,4)=a33der*xj
2181           agg(2,4)=a33der*yj
2182           agg(3,4)=a33der*zj
2183 C Add the contributions coming from er
2184           fac3=-3.0d0*fac
2185           do k=1,3
2186             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2187             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2188             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2189             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2190           enddo
2191           do k=1,3
2192 C Derivatives in DC(i)
2193             ghalf1=0.5d0*agg(k,1)
2194             ghalf2=0.5d0*agg(k,2)
2195             ghalf3=0.5d0*agg(k,3)
2196             ghalf4=0.5d0*agg(k,4)
2197             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2198      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2199             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2200      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2201             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2202      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2203             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2204      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2205 C Derivatives in DC(i+1)
2206             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2207      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2208             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2209      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2210             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2211      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2212             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2213      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2214 C Derivatives in DC(j)
2215             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2216      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2217             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2218      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2219             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2220      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2221             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2222      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2223 C Derivatives in DC(j+1) or DC(nres-1)
2224             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2225      &      -3.0d0*vryg(k,3)*ury)
2226             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2227      &      -3.0d0*vrzg(k,3)*ury)
2228             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2229      &      -3.0d0*vryg(k,3)*urz)
2230             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2231      &      -3.0d0*vrzg(k,3)*urz)
2232 cd            aggi(k,1)=ghalf1
2233 cd            aggi(k,2)=ghalf2
2234 cd            aggi(k,3)=ghalf3
2235 cd            aggi(k,4)=ghalf4
2236 C Derivatives in DC(i+1)
2237 cd            aggi1(k,1)=agg(k,1)
2238 cd            aggi1(k,2)=agg(k,2)
2239 cd            aggi1(k,3)=agg(k,3)
2240 cd            aggi1(k,4)=agg(k,4)
2241 C Derivatives in DC(j)
2242 cd            aggj(k,1)=ghalf1
2243 cd            aggj(k,2)=ghalf2
2244 cd            aggj(k,3)=ghalf3
2245 cd            aggj(k,4)=ghalf4
2246 C Derivatives in DC(j+1)
2247 cd            aggj1(k,1)=0.0d0
2248 cd            aggj1(k,2)=0.0d0
2249 cd            aggj1(k,3)=0.0d0
2250 cd            aggj1(k,4)=0.0d0
2251             if (j.eq.nres-1 .and. i.lt.j-2) then
2252               do l=1,4
2253                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2254 cd                aggj1(k,l)=agg(k,l)
2255               enddo
2256             endif
2257           enddo
2258           endif
2259 c          goto 11111
2260 C Check the loc-el terms by numerical integration
2261           acipa(1,1)=a22
2262           acipa(1,2)=a23
2263           acipa(2,1)=a32
2264           acipa(2,2)=a33
2265           a22=-a22
2266           a23=-a23
2267           do l=1,2
2268             do k=1,3
2269               agg(k,l)=-agg(k,l)
2270               aggi(k,l)=-aggi(k,l)
2271               aggi1(k,l)=-aggi1(k,l)
2272               aggj(k,l)=-aggj(k,l)
2273               aggj1(k,l)=-aggj1(k,l)
2274             enddo
2275           enddo
2276           if (j.lt.nres-1) then
2277             a22=-a22
2278             a32=-a32
2279             do l=1,3,2
2280               do k=1,3
2281                 agg(k,l)=-agg(k,l)
2282                 aggi(k,l)=-aggi(k,l)
2283                 aggi1(k,l)=-aggi1(k,l)
2284                 aggj(k,l)=-aggj(k,l)
2285                 aggj1(k,l)=-aggj1(k,l)
2286               enddo
2287             enddo
2288           else
2289             a22=-a22
2290             a23=-a23
2291             a32=-a32
2292             a33=-a33
2293             do l=1,4
2294               do k=1,3
2295                 agg(k,l)=-agg(k,l)
2296                 aggi(k,l)=-aggi(k,l)
2297                 aggi1(k,l)=-aggi1(k,l)
2298                 aggj(k,l)=-aggj(k,l)
2299                 aggj1(k,l)=-aggj1(k,l)
2300               enddo
2301             enddo
2302           endif
2303           ENDIF ! WCORR
2304 11111     continue
2305           IF (wel_loc.gt.0.0d0) THEN
2306 C Contribution to the local-electrostatic energy coming from the i-j pair
2307           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2308      &     +a33*muij(4)
2309 c          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2310 c          write (iout,'(a6,2i5,0pf7.3)')
2311 c     &            'eelloc',i,j,eel_loc_ij
2312 c          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2313           eel_loc=eel_loc+eel_loc_ij
2314 C Partial derivatives in virtual-bond dihedral angles gamma
2315           if (calc_grad) then
2316           if (i.gt.1)
2317      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2318      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2319      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2320           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2321      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2322      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2323 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2324 cd          write(iout,*) 'agg  ',agg
2325 cd          write(iout,*) 'aggi ',aggi
2326 cd          write(iout,*) 'aggi1',aggi1
2327 cd          write(iout,*) 'aggj ',aggj
2328 cd          write(iout,*) 'aggj1',aggj1
2329
2330 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2331           do l=1,3
2332             ggg(l)=agg(l,1)*muij(1)+
2333      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2334           enddo
2335           do k=i+2,j2
2336             do l=1,3
2337               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2338             enddo
2339           enddo
2340 C Remaining derivatives of eello
2341           do l=1,3
2342             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2343      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2344             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2345      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2346             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2347      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2348             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2349      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2350           enddo
2351           endif
2352           ENDIF
2353           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2354 C Contributions from turns
2355             a_temp(1,1)=a22
2356             a_temp(1,2)=a23
2357             a_temp(2,1)=a32
2358             a_temp(2,2)=a33
2359             call eturn34(i,j,eello_turn3,eello_turn4)
2360           endif
2361 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2362           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2363 C
2364 C Calculate the contact function. The ith column of the array JCONT will
2365 C contain the numbers of atoms that make contacts with the atom I (of numbers
2366 C greater than I). The arrays FACONT and GACONT will contain the values of
2367 C the contact function and its derivative.
2368 c           r0ij=1.02D0*rpp(iteli,itelj)
2369 c           r0ij=1.11D0*rpp(iteli,itelj)
2370             r0ij=2.20D0*rpp(iteli,itelj)
2371 c           r0ij=1.55D0*rpp(iteli,itelj)
2372             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2373             if (fcont.gt.0.0D0) then
2374               num_conti=num_conti+1
2375               if (num_conti.gt.maxconts) then
2376                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2377      &                         ' will skip next contacts for this conf.'
2378               else
2379                 jcont_hb(num_conti,i)=j
2380                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2381      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2382 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2383 C  terms.
2384                 d_cont(num_conti,i)=rij
2385 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2386 C     --- Electrostatic-interaction matrix ---
2387                 a_chuj(1,1,num_conti,i)=a22
2388                 a_chuj(1,2,num_conti,i)=a23
2389                 a_chuj(2,1,num_conti,i)=a32
2390                 a_chuj(2,2,num_conti,i)=a33
2391 C     --- Gradient of rij
2392                 do kkk=1,3
2393                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2394                 enddo
2395 c             if (i.eq.1) then
2396 c                a_chuj(1,1,num_conti,i)=-0.61d0
2397 c                a_chuj(1,2,num_conti,i)= 0.4d0
2398 c                a_chuj(2,1,num_conti,i)= 0.65d0
2399 c                a_chuj(2,2,num_conti,i)= 0.50d0
2400 c             else if (i.eq.2) then
2401 c                a_chuj(1,1,num_conti,i)= 0.0d0
2402 c                a_chuj(1,2,num_conti,i)= 0.0d0
2403 c                a_chuj(2,1,num_conti,i)= 0.0d0
2404 c                a_chuj(2,2,num_conti,i)= 0.0d0
2405 c             endif
2406 C     --- and its gradients
2407 cd                write (iout,*) 'i',i,' j',j
2408 cd                do kkk=1,3
2409 cd                write (iout,*) 'iii 1 kkk',kkk
2410 cd                write (iout,*) agg(kkk,:)
2411 cd                enddo
2412 cd                do kkk=1,3
2413 cd                write (iout,*) 'iii 2 kkk',kkk
2414 cd                write (iout,*) aggi(kkk,:)
2415 cd                enddo
2416 cd                do kkk=1,3
2417 cd                write (iout,*) 'iii 3 kkk',kkk
2418 cd                write (iout,*) aggi1(kkk,:)
2419 cd                enddo
2420 cd                do kkk=1,3
2421 cd                write (iout,*) 'iii 4 kkk',kkk
2422 cd                write (iout,*) aggj(kkk,:)
2423 cd                enddo
2424 cd                do kkk=1,3
2425 cd                write (iout,*) 'iii 5 kkk',kkk
2426 cd                write (iout,*) aggj1(kkk,:)
2427 cd                enddo
2428                 kkll=0
2429                 do k=1,2
2430                   do l=1,2
2431                     kkll=kkll+1
2432                     do m=1,3
2433                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2434                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2435                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2436                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2437                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2438 c                      do mm=1,5
2439 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2440 c                      enddo
2441                     enddo
2442                   enddo
2443                 enddo
2444                 ENDIF
2445                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2446 C Calculate contact energies
2447                 cosa4=4.0D0*cosa
2448                 wij=cosa-3.0D0*cosb*cosg
2449                 cosbg1=cosb+cosg
2450                 cosbg2=cosb-cosg
2451 c               fac3=dsqrt(-ael6i)/r0ij**3
2452                 fac3=dsqrt(-ael6i)*r3ij
2453                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2454                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2455 c               ees0mij=0.0D0
2456                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2457                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2458 C Diagnostics. Comment out or remove after debugging!
2459 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2460 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2461 c               ees0m(num_conti,i)=0.0D0
2462 C End diagnostics.
2463 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2464 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2465                 facont_hb(num_conti,i)=fcont
2466                 if (calc_grad) then
2467 C Angular derivatives of the contact function
2468                 ees0pij1=fac3/ees0pij
2469                 ees0mij1=fac3/ees0mij
2470                 fac3p=-3.0D0*fac3*rrmij
2471                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2472                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2473 c               ees0mij1=0.0D0
2474                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2475                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2476                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2477                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2478                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2479                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2480                 ecosap=ecosa1+ecosa2
2481                 ecosbp=ecosb1+ecosb2
2482                 ecosgp=ecosg1+ecosg2
2483                 ecosam=ecosa1-ecosa2
2484                 ecosbm=ecosb1-ecosb2
2485                 ecosgm=ecosg1-ecosg2
2486 C Diagnostics
2487 c               ecosap=ecosa1
2488 c               ecosbp=ecosb1
2489 c               ecosgp=ecosg1
2490 c               ecosam=0.0D0
2491 c               ecosbm=0.0D0
2492 c               ecosgm=0.0D0
2493 C End diagnostics
2494                 fprimcont=fprimcont/rij
2495 cd              facont_hb(num_conti,i)=1.0D0
2496 C Following line is for diagnostics.
2497 cd              fprimcont=0.0D0
2498                 do k=1,3
2499                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2500                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2501                 enddo
2502                 do k=1,3
2503                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2504                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2505                 enddo
2506                 gggp(1)=gggp(1)+ees0pijp*xj
2507                 gggp(2)=gggp(2)+ees0pijp*yj
2508                 gggp(3)=gggp(3)+ees0pijp*zj
2509                 gggm(1)=gggm(1)+ees0mijp*xj
2510                 gggm(2)=gggm(2)+ees0mijp*yj
2511                 gggm(3)=gggm(3)+ees0mijp*zj
2512 C Derivatives due to the contact function
2513                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2514                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2515                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2516                 do k=1,3
2517                   ghalfp=0.5D0*gggp(k)
2518                   ghalfm=0.5D0*gggm(k)
2519                   gacontp_hb1(k,num_conti,i)=ghalfp
2520      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2521      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2522                   gacontp_hb2(k,num_conti,i)=ghalfp
2523      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2524      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2525                   gacontp_hb3(k,num_conti,i)=gggp(k)
2526                   gacontm_hb1(k,num_conti,i)=ghalfm
2527      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2528      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2529                   gacontm_hb2(k,num_conti,i)=ghalfm
2530      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2531      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2532                   gacontm_hb3(k,num_conti,i)=gggm(k)
2533                 enddo
2534                 endif
2535 C Diagnostics. Comment out or remove after debugging!
2536 cdiag           do k=1,3
2537 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2538 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2539 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2540 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2541 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2542 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2543 cdiag           enddo
2544               ENDIF ! wcorr
2545               endif  ! num_conti.le.maxconts
2546             endif  ! fcont.gt.0
2547           endif    ! j.gt.i+1
2548  1216     continue
2549         enddo ! j
2550         num_cont_hb(i)=num_conti
2551  1215   continue
2552       enddo   ! i
2553 cd      do i=1,nres
2554 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2555 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2556 cd      enddo
2557 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2558 ccc      eel_loc=eel_loc+eello_turn3
2559       return
2560       end
2561 C-----------------------------------------------------------------------------
2562       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2563 C Third- and fourth-order contributions from turns
2564       implicit real*8 (a-h,o-z)
2565       include 'DIMENSIONS'
2566       include 'DIMENSIONS.ZSCOPT'
2567       include 'COMMON.IOUNITS'
2568       include 'COMMON.GEO'
2569       include 'COMMON.VAR'
2570       include 'COMMON.LOCAL'
2571       include 'COMMON.CHAIN'
2572       include 'COMMON.DERIV'
2573       include 'COMMON.INTERACT'
2574       include 'COMMON.CONTACTS'
2575       include 'COMMON.TORSION'
2576       include 'COMMON.VECTORS'
2577       include 'COMMON.FFIELD'
2578       dimension ggg(3)
2579       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2580      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2581      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2582       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2583      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2584       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2585       if (j.eq.i+2) then
2586 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2587 C
2588 C               Third-order contributions
2589 C
2590 C                 (i+2)o----(i+3)
2591 C                      | |
2592 C                      | |
2593 C                 (i+1)o----i
2594 C
2595 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2596 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2597         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2598         call transpose2(auxmat(1,1),auxmat1(1,1))
2599         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2600         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2601 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2602 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2603 cd     &    ' eello_turn3_num',4*eello_turn3_num
2604         if (calc_grad) then
2605 C Derivatives in gamma(i)
2606         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2607         call transpose2(auxmat2(1,1),pizda(1,1))
2608         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2609         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2610 C Derivatives in gamma(i+1)
2611         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2612         call transpose2(auxmat2(1,1),pizda(1,1))
2613         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2614         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2615      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2616 C Cartesian derivatives
2617         do l=1,3
2618           a_temp(1,1)=aggi(l,1)
2619           a_temp(1,2)=aggi(l,2)
2620           a_temp(2,1)=aggi(l,3)
2621           a_temp(2,2)=aggi(l,4)
2622           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2623           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2624      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2625           a_temp(1,1)=aggi1(l,1)
2626           a_temp(1,2)=aggi1(l,2)
2627           a_temp(2,1)=aggi1(l,3)
2628           a_temp(2,2)=aggi1(l,4)
2629           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2630           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2631      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2632           a_temp(1,1)=aggj(l,1)
2633           a_temp(1,2)=aggj(l,2)
2634           a_temp(2,1)=aggj(l,3)
2635           a_temp(2,2)=aggj(l,4)
2636           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2637           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2638      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2639           a_temp(1,1)=aggj1(l,1)
2640           a_temp(1,2)=aggj1(l,2)
2641           a_temp(2,1)=aggj1(l,3)
2642           a_temp(2,2)=aggj1(l,4)
2643           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2644           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2645      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2646         enddo
2647         endif
2648       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
2649 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2650 C
2651 C               Fourth-order contributions
2652 C
2653 C                 (i+3)o----(i+4)
2654 C                     /  |
2655 C               (i+2)o   |
2656 C                     \  |
2657 C                 (i+1)o----i
2658 C
2659 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2660 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2661         iti1=itortyp(itype(i+1))
2662         iti2=itortyp(itype(i+2))
2663         iti3=itortyp(itype(i+3))
2664         call transpose2(EUg(1,1,i+1),e1t(1,1))
2665         call transpose2(Eug(1,1,i+2),e2t(1,1))
2666         call transpose2(Eug(1,1,i+3),e3t(1,1))
2667         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2668         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2669         s1=scalar2(b1(1,iti2),auxvec(1))
2670         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2671         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2672         s2=scalar2(b1(1,iti1),auxvec(1))
2673         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2674         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2675         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2676         eello_turn4=eello_turn4-(s1+s2+s3)
2677 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2678 cd     &    ' eello_turn4_num',8*eello_turn4_num
2679 C Derivatives in gamma(i)
2680         if (calc_grad) then
2681         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2682         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2683         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2684         s1=scalar2(b1(1,iti2),auxvec(1))
2685         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2686         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2687         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2688 C Derivatives in gamma(i+1)
2689         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2690         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2691         s2=scalar2(b1(1,iti1),auxvec(1))
2692         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2693         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2694         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2695         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2696 C Derivatives in gamma(i+2)
2697         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2698         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2699         s1=scalar2(b1(1,iti2),auxvec(1))
2700         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2701         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2702         s2=scalar2(b1(1,iti1),auxvec(1))
2703         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2704         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2705         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2706         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2707 C Cartesian derivatives
2708 C Derivatives of this turn contributions in DC(i+2)
2709         if (j.lt.nres-1) then
2710           do l=1,3
2711             a_temp(1,1)=agg(l,1)
2712             a_temp(1,2)=agg(l,2)
2713             a_temp(2,1)=agg(l,3)
2714             a_temp(2,2)=agg(l,4)
2715             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2716             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2717             s1=scalar2(b1(1,iti2),auxvec(1))
2718             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2719             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2720             s2=scalar2(b1(1,iti1),auxvec(1))
2721             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2722             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2723             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2724             ggg(l)=-(s1+s2+s3)
2725             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2726           enddo
2727         endif
2728 C Remaining derivatives of this turn contribution
2729         do l=1,3
2730           a_temp(1,1)=aggi(l,1)
2731           a_temp(1,2)=aggi(l,2)
2732           a_temp(2,1)=aggi(l,3)
2733           a_temp(2,2)=aggi(l,4)
2734           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2735           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2736           s1=scalar2(b1(1,iti2),auxvec(1))
2737           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2738           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2739           s2=scalar2(b1(1,iti1),auxvec(1))
2740           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2741           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2742           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2743           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2744           a_temp(1,1)=aggi1(l,1)
2745           a_temp(1,2)=aggi1(l,2)
2746           a_temp(2,1)=aggi1(l,3)
2747           a_temp(2,2)=aggi1(l,4)
2748           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2749           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2750           s1=scalar2(b1(1,iti2),auxvec(1))
2751           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2752           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2753           s2=scalar2(b1(1,iti1),auxvec(1))
2754           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2755           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2756           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2757           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2758           a_temp(1,1)=aggj(l,1)
2759           a_temp(1,2)=aggj(l,2)
2760           a_temp(2,1)=aggj(l,3)
2761           a_temp(2,2)=aggj(l,4)
2762           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2763           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2764           s1=scalar2(b1(1,iti2),auxvec(1))
2765           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2766           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2767           s2=scalar2(b1(1,iti1),auxvec(1))
2768           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2769           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2770           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2771           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2772           a_temp(1,1)=aggj1(l,1)
2773           a_temp(1,2)=aggj1(l,2)
2774           a_temp(2,1)=aggj1(l,3)
2775           a_temp(2,2)=aggj1(l,4)
2776           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2777           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2778           s1=scalar2(b1(1,iti2),auxvec(1))
2779           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2780           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2781           s2=scalar2(b1(1,iti1),auxvec(1))
2782           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2783           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2784           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2785           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2786         enddo
2787         endif
2788       endif
2789       return
2790       end
2791 C-----------------------------------------------------------------------------
2792       subroutine vecpr(u,v,w)
2793       implicit real*8(a-h,o-z)
2794       dimension u(3),v(3),w(3)
2795       w(1)=u(2)*v(3)-u(3)*v(2)
2796       w(2)=-u(1)*v(3)+u(3)*v(1)
2797       w(3)=u(1)*v(2)-u(2)*v(1)
2798       return
2799       end
2800 C-----------------------------------------------------------------------------
2801       subroutine unormderiv(u,ugrad,unorm,ungrad)
2802 C This subroutine computes the derivatives of a normalized vector u, given
2803 C the derivatives computed without normalization conditions, ugrad. Returns
2804 C ungrad.
2805       implicit none
2806       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2807       double precision vec(3)
2808       double precision scalar
2809       integer i,j
2810 c      write (2,*) 'ugrad',ugrad
2811 c      write (2,*) 'u',u
2812       do i=1,3
2813         vec(i)=scalar(ugrad(1,i),u(1))
2814       enddo
2815 c      write (2,*) 'vec',vec
2816       do i=1,3
2817         do j=1,3
2818           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2819         enddo
2820       enddo
2821 c      write (2,*) 'ungrad',ungrad
2822       return
2823       end
2824 C-----------------------------------------------------------------------------
2825       subroutine escp(evdw2,evdw2_14)
2826 C
2827 C This subroutine calculates the excluded-volume interaction energy between
2828 C peptide-group centers and side chains and its gradient in virtual-bond and
2829 C side-chain vectors.
2830 C
2831       implicit real*8 (a-h,o-z)
2832       include 'DIMENSIONS'
2833       include 'DIMENSIONS.ZSCOPT'
2834       include 'COMMON.GEO'
2835       include 'COMMON.VAR'
2836       include 'COMMON.LOCAL'
2837       include 'COMMON.CHAIN'
2838       include 'COMMON.DERIV'
2839       include 'COMMON.INTERACT'
2840       include 'COMMON.FFIELD'
2841       include 'COMMON.IOUNITS'
2842       dimension ggg(3)
2843       evdw2=0.0D0
2844       evdw2_14=0.0d0
2845 cd    print '(a)','Enter ESCP'
2846 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2847 c     &  ' scal14',scal14
2848       do i=iatscp_s,iatscp_e
2849         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2850         iteli=itel(i)
2851 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2852 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2853         if (iteli.eq.0) goto 1225
2854         xi=0.5D0*(c(1,i)+c(1,i+1))
2855         yi=0.5D0*(c(2,i)+c(2,i+1))
2856         zi=0.5D0*(c(3,i)+c(3,i+1))
2857
2858         do iint=1,nscp_gr(i)
2859
2860         do j=iscpstart(i,iint),iscpend(i,iint)
2861           itypj=iabs(itype(j))
2862           if (itypj.eq.ntyp1) cycle
2863 C Uncomment following three lines for SC-p interactions
2864 c         xj=c(1,nres+j)-xi
2865 c         yj=c(2,nres+j)-yi
2866 c         zj=c(3,nres+j)-zi
2867 C Uncomment following three lines for Ca-p interactions
2868           xj=c(1,j)-xi
2869           yj=c(2,j)-yi
2870           zj=c(3,j)-zi
2871           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2872           fac=rrij**expon2
2873           e1=fac*fac*aad(itypj,iteli)
2874           e2=fac*bad(itypj,iteli)
2875           if (iabs(j-i) .le. 2) then
2876             e1=scal14*e1
2877             e2=scal14*e2
2878             evdw2_14=evdw2_14+e1+e2
2879           endif
2880           evdwij=e1+e2
2881 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
2882 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
2883 c     &       bad(itypj,iteli)
2884           evdw2=evdw2+evdwij
2885           if (calc_grad) then
2886 C
2887 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2888 C
2889           fac=-(evdwij+e1)*rrij
2890           ggg(1)=xj*fac
2891           ggg(2)=yj*fac
2892           ggg(3)=zj*fac
2893           if (j.lt.i) then
2894 cd          write (iout,*) 'j<i'
2895 C Uncomment following three lines for SC-p interactions
2896 c           do k=1,3
2897 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2898 c           enddo
2899           else
2900 cd          write (iout,*) 'j>i'
2901             do k=1,3
2902               ggg(k)=-ggg(k)
2903 C Uncomment following line for SC-p interactions
2904 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2905             enddo
2906           endif
2907           do k=1,3
2908             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2909           enddo
2910           kstart=min0(i+1,j)
2911           kend=max0(i-1,j-1)
2912 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2913 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2914           do k=kstart,kend
2915             do l=1,3
2916               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2917             enddo
2918           enddo
2919           endif
2920         enddo
2921         enddo ! iint
2922  1225   continue
2923       enddo ! i
2924       do i=1,nct
2925         do j=1,3
2926           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2927           gradx_scp(j,i)=expon*gradx_scp(j,i)
2928         enddo
2929       enddo
2930 C******************************************************************************
2931 C
2932 C                              N O T E !!!
2933 C
2934 C To save time the factor EXPON has been extracted from ALL components
2935 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2936 C use!
2937 C
2938 C******************************************************************************
2939       return
2940       end
2941 C--------------------------------------------------------------------------
2942       subroutine edis(ehpb)
2943 C
2944 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2945 C
2946       implicit real*8 (a-h,o-z)
2947       include 'DIMENSIONS'
2948       include 'DIMENSIONS.ZSCOPT'
2949       include 'COMMON.SBRIDGE'
2950       include 'COMMON.CHAIN'
2951       include 'COMMON.DERIV'
2952       include 'COMMON.VAR'
2953       include 'COMMON.INTERACT'
2954       include 'COMMON.CONTROL'
2955       include 'COMMON.IOUNITS'
2956       dimension ggg(3)
2957       ehpb=0.0D0
2958 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
2959 cd    print *,'link_start=',link_start,' link_end=',link_end
2960 C      write(iout,*) link_end, "link_end"
2961       if (link_end.eq.0) return
2962       do i=link_start,link_end
2963 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2964 C CA-CA distance used in regularization of structure.
2965         ii=ihpb(i)
2966         jj=jhpb(i)
2967 C iii and jjj point to the residues for which the distance is assigned.
2968         if (ii.gt.nres) then
2969           iii=ii-nres
2970           jjj=jj-nres
2971         else
2972           iii=ii
2973           jjj=jj
2974         endif
2975 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2976 C    distance and angle dependent SS bond potential.
2977 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
2978 C     & iabs(itype(jjj)).eq.1) then
2979 C       write(iout,*) constr_dist,"const"
2980        if (.not.dyn_ss .and. i.le.nss) then
2981          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
2982      & iabs(itype(jjj)).eq.1) then
2983           call ssbond_ene(iii,jjj,eij)
2984           ehpb=ehpb+2*eij
2985            endif !ii.gt.neres
2986         else if (ii.gt.nres .and. jj.gt.nres) then
2987 c Restraints from contact prediction
2988           dd=dist(ii,jj)
2989           if (constr_dist.eq.11) then
2990 C            ehpb=ehpb+fordepth(i)**4.0d0
2991 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
2992             ehpb=ehpb+fordepth(i)**4.0d0
2993      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
2994             fac=fordepth(i)**4.0d0
2995      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
2996 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
2997 C     &    ehpb,fordepth(i),dd
2998 C            write(iout,*) ehpb,"atu?"
2999 C            ehpb,"tu?"
3000 C            fac=fordepth(i)**4.0d0
3001 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3002            else
3003           if (dhpb1(i).gt.0.0d0) then
3004             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3005             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3006 c            write (iout,*) "beta nmr",
3007 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3008           else
3009             dd=dist(ii,jj)
3010             rdis=dd-dhpb(i)
3011 C Get the force constant corresponding to this distance.
3012             waga=forcon(i)
3013 C Calculate the contribution to energy.
3014             ehpb=ehpb+waga*rdis*rdis
3015 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3016 C
3017 C Evaluate gradient.
3018 C
3019             fac=waga*rdis/dd
3020           endif !end dhpb1(i).gt.0
3021           endif !end const_dist=11
3022           do j=1,3
3023             ggg(j)=fac*(c(j,jj)-c(j,ii))
3024           enddo
3025           do j=1,3
3026             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3027             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3028           enddo
3029           do k=1,3
3030             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3031             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3032           enddo
3033         else !ii.gt.nres
3034 C          write(iout,*) "before"
3035           dd=dist(ii,jj)
3036 C          write(iout,*) "after",dd
3037           if (constr_dist.eq.11) then
3038             ehpb=ehpb+fordepth(i)**4.0d0
3039      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3040             fac=fordepth(i)**4.0d0
3041      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3042 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3043 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3044 C            print *,ehpb,"tu?"
3045 C            write(iout,*) ehpb,"btu?",
3046 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3047 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3048 C     &    ehpb,fordepth(i),dd
3049            else
3050           if (dhpb1(i).gt.0.0d0) then
3051             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3052             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3053 c            write (iout,*) "alph nmr",
3054 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3055           else
3056             rdis=dd-dhpb(i)
3057 C Get the force constant corresponding to this distance.
3058             waga=forcon(i)
3059 C Calculate the contribution to energy.
3060             ehpb=ehpb+waga*rdis*rdis
3061 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3062 C
3063 C Evaluate gradient.
3064 C
3065             fac=waga*rdis/dd
3066           endif
3067           endif
3068
3069         do j=1,3
3070           ggg(j)=fac*(c(j,jj)-c(j,ii))
3071         enddo
3072 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3073 C If this is a SC-SC distance, we need to calculate the contributions to the
3074 C Cartesian gradient in the SC vectors (ghpbx).
3075         if (iii.lt.ii) then
3076           do j=1,3
3077             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3078             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3079           enddo
3080         endif
3081         do j=iii,jjj-1
3082           do k=1,3
3083             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3084           enddo
3085         enddo
3086         endif
3087       enddo
3088       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3089       return
3090       end
3091 C--------------------------------------------------------------------------
3092       subroutine ssbond_ene(i,j,eij)
3093 C
3094 C Calculate the distance and angle dependent SS-bond potential energy
3095 C using a free-energy function derived based on RHF/6-31G** ab initio
3096 C calculations of diethyl disulfide.
3097 C
3098 C A. Liwo and U. Kozlowska, 11/24/03
3099 C
3100       implicit real*8 (a-h,o-z)
3101       include 'DIMENSIONS'
3102       include 'DIMENSIONS.ZSCOPT'
3103       include 'COMMON.SBRIDGE'
3104       include 'COMMON.CHAIN'
3105       include 'COMMON.DERIV'
3106       include 'COMMON.LOCAL'
3107       include 'COMMON.INTERACT'
3108       include 'COMMON.VAR'
3109       include 'COMMON.IOUNITS'
3110       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3111       itypi=iabs(itype(i))
3112       xi=c(1,nres+i)
3113       yi=c(2,nres+i)
3114       zi=c(3,nres+i)
3115       dxi=dc_norm(1,nres+i)
3116       dyi=dc_norm(2,nres+i)
3117       dzi=dc_norm(3,nres+i)
3118       dsci_inv=dsc_inv(itypi)
3119       itypj=iabs(itype(j))
3120       dscj_inv=dsc_inv(itypj)
3121       xj=c(1,nres+j)-xi
3122       yj=c(2,nres+j)-yi
3123       zj=c(3,nres+j)-zi
3124       dxj=dc_norm(1,nres+j)
3125       dyj=dc_norm(2,nres+j)
3126       dzj=dc_norm(3,nres+j)
3127       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3128       rij=dsqrt(rrij)
3129       erij(1)=xj*rij
3130       erij(2)=yj*rij
3131       erij(3)=zj*rij
3132       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3133       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3134       om12=dxi*dxj+dyi*dyj+dzi*dzj
3135       do k=1,3
3136         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3137         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3138       enddo
3139       rij=1.0d0/rij
3140       deltad=rij-d0cm
3141       deltat1=1.0d0-om1
3142       deltat2=1.0d0+om2
3143       deltat12=om2-om1+2.0d0
3144       cosphi=om12-om1*om2
3145       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3146      &  +akct*deltad*deltat12
3147      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3148 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3149 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3150 c     &  " deltat12",deltat12," eij",eij
3151       ed=2*akcm*deltad+akct*deltat12
3152       pom1=akct*deltad
3153       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3154       eom1=-2*akth*deltat1-pom1-om2*pom2
3155       eom2= 2*akth*deltat2+pom1-om1*pom2
3156       eom12=pom2
3157       do k=1,3
3158         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3159       enddo
3160       do k=1,3
3161         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3162      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3163         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3164      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3165       enddo
3166 C
3167 C Calculate the components of the gradient in DC and X
3168 C
3169       do k=i,j-1
3170         do l=1,3
3171           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3172         enddo
3173       enddo
3174       return
3175       end
3176 C--------------------------------------------------------------------------
3177       subroutine ebond(estr)
3178 c
3179 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3180 c
3181       implicit real*8 (a-h,o-z)
3182       include 'DIMENSIONS'
3183       include 'DIMENSIONS.ZSCOPT'
3184       include 'COMMON.LOCAL'
3185       include 'COMMON.GEO'
3186       include 'COMMON.INTERACT'
3187       include 'COMMON.DERIV'
3188       include 'COMMON.VAR'
3189       include 'COMMON.CHAIN'
3190       include 'COMMON.IOUNITS'
3191       include 'COMMON.NAMES'
3192       include 'COMMON.FFIELD'
3193       include 'COMMON.CONTROL'
3194       logical energy_dec /.false./
3195       double precision u(3),ud(3)
3196       estr=0.0d0
3197       estr1=0.0d0
3198 c      write (iout,*) "distchainmax",distchainmax
3199       do i=nnt+1,nct
3200         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
3201           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3202           do j=1,3
3203           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3204      &      *dc(j,i-1)/vbld(i)
3205           enddo
3206           if (energy_dec) write(iout,*)
3207      &       "estr1",i,vbld(i),distchainmax,
3208      &       gnmr1(vbld(i),-1.0d0,distchainmax)
3209         else
3210           diff = vbld(i)-vbldp0
3211 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3212           estr=estr+diff*diff
3213           do j=1,3
3214             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3215           enddo
3216         endif
3217
3218       enddo
3219       estr=0.5d0*AKP*estr+estr1
3220 c
3221 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3222 c
3223       do i=nnt,nct
3224         iti=iabs(itype(i))
3225         if (iti.ne.10 .and. iti.ne.ntyp1) then
3226           nbi=nbondterm(iti)
3227           if (nbi.eq.1) then
3228             diff=vbld(i+nres)-vbldsc0(1,iti)
3229 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3230 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3231             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3232             do j=1,3
3233               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3234             enddo
3235           else
3236             do j=1,nbi
3237               diff=vbld(i+nres)-vbldsc0(j,iti)
3238               ud(j)=aksc(j,iti)*diff
3239               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3240             enddo
3241             uprod=u(1)
3242             do j=2,nbi
3243               uprod=uprod*u(j)
3244             enddo
3245             usum=0.0d0
3246             usumsqder=0.0d0
3247             do j=1,nbi
3248               uprod1=1.0d0
3249               uprod2=1.0d0
3250               do k=1,nbi
3251                 if (k.ne.j) then
3252                   uprod1=uprod1*u(k)
3253                   uprod2=uprod2*u(k)*u(k)
3254                 endif
3255               enddo
3256               usum=usum+uprod1
3257               usumsqder=usumsqder+ud(j)*uprod2
3258             enddo
3259 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3260 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3261             estr=estr+uprod/usum
3262             do j=1,3
3263              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3264             enddo
3265           endif
3266         endif
3267       enddo
3268       return
3269       end
3270 #ifdef CRYST_THETA
3271 C--------------------------------------------------------------------------
3272       subroutine ebend(etheta,ethetacnstr)
3273 C
3274 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3275 C angles gamma and its derivatives in consecutive thetas and gammas.
3276 C
3277       implicit real*8 (a-h,o-z)
3278       include 'DIMENSIONS'
3279       include 'DIMENSIONS.ZSCOPT'
3280       include 'COMMON.LOCAL'
3281       include 'COMMON.GEO'
3282       include 'COMMON.INTERACT'
3283       include 'COMMON.DERIV'
3284       include 'COMMON.VAR'
3285       include 'COMMON.CHAIN'
3286       include 'COMMON.IOUNITS'
3287       include 'COMMON.NAMES'
3288       include 'COMMON.FFIELD'
3289       include 'COMMON.TORCNSTR'
3290       common /calcthet/ term1,term2,termm,diffak,ratak,
3291      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3292      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3293       double precision y(2),z(2)
3294       delta=0.02d0*pi
3295 c      time11=dexp(-2*time)
3296 c      time12=1.0d0
3297       etheta=0.0D0
3298 c      write (iout,*) "nres",nres
3299 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3300 c      write (iout,*) ithet_start,ithet_end
3301       do i=ithet_start,ithet_end
3302         if (itype(i-1).eq.ntyp1) cycle
3303 C Zero the energy function and its derivative at 0 or pi.
3304         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3305         it=itype(i-1)
3306         ichir1=isign(1,itype(i-2))
3307         ichir2=isign(1,itype(i))
3308          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
3309          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
3310          if (itype(i-1).eq.10) then
3311           itype1=isign(10,itype(i-2))
3312           ichir11=isign(1,itype(i-2))
3313           ichir12=isign(1,itype(i-2))
3314           itype2=isign(10,itype(i))
3315           ichir21=isign(1,itype(i))
3316           ichir22=isign(1,itype(i))
3317          endif
3318
3319         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
3320 #ifdef OSF
3321           phii=phi(i)
3322 c          icrc=0
3323 c          call proc_proc(phii,icrc)
3324           if (icrc.eq.1) phii=150.0
3325 #else
3326           phii=phi(i)
3327 #endif
3328           y(1)=dcos(phii)
3329           y(2)=dsin(phii)
3330         else
3331           y(1)=0.0D0
3332           y(2)=0.0D0
3333         endif
3334         if (i.lt.nres .and. itype(i).ne.ntyp1) then
3335 #ifdef OSF
3336           phii1=phi(i+1)
3337 c          icrc=0
3338 c          call proc_proc(phii1,icrc)
3339           if (icrc.eq.1) phii1=150.0
3340           phii1=pinorm(phii1)
3341           z(1)=cos(phii1)
3342 #else
3343           phii1=phi(i+1)
3344           z(1)=dcos(phii1)
3345 #endif
3346           z(2)=dsin(phii1)
3347         else
3348           z(1)=0.0D0
3349           z(2)=0.0D0
3350         endif
3351 C Calculate the "mean" value of theta from the part of the distribution
3352 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3353 C In following comments this theta will be referred to as t_c.
3354         thet_pred_mean=0.0d0
3355         do k=1,2
3356             athetk=athet(k,it,ichir1,ichir2)
3357             bthetk=bthet(k,it,ichir1,ichir2)
3358           if (it.eq.10) then
3359              athetk=athet(k,itype1,ichir11,ichir12)
3360              bthetk=bthet(k,itype2,ichir21,ichir22)
3361           endif
3362           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3363         enddo
3364 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3365         dthett=thet_pred_mean*ssd
3366         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3367 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3368 C Derivatives of the "mean" values in gamma1 and gamma2.
3369         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
3370      &+athet(2,it,ichir1,ichir2)*y(1))*ss
3371          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
3372      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
3373          if (it.eq.10) then
3374       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
3375      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
3376         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
3377      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
3378          endif
3379         if (theta(i).gt.pi-delta) then
3380           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3381      &         E_tc0)
3382           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3383           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3384           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3385      &        E_theta)
3386           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3387      &        E_tc)
3388         else if (theta(i).lt.delta) then
3389           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3390           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3391           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3392      &        E_theta)
3393           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3394           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3395      &        E_tc)
3396         else
3397           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3398      &        E_theta,E_tc)
3399         endif
3400         etheta=etheta+ethetai
3401 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3402 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3403         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3404         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3405         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3406 c 1215   continue
3407       enddo
3408       ethetacnstr=0.0d0
3409 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
3410       do i=1,ntheta_constr
3411         itheta=itheta_constr(i)
3412         thetiii=theta(itheta)
3413         difi=pinorm(thetiii-theta_constr0(i))
3414         if (difi.gt.theta_drange(i)) then
3415           difi=difi-theta_drange(i)
3416           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
3417           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
3418      &    +for_thet_constr(i)*difi**3
3419         else if (difi.lt.-drange(i)) then
3420           difi=difi+drange(i)
3421           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
3422           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
3423      &    +for_thet_constr(i)*difi**3
3424         else
3425           difi=0.0
3426         endif
3427 C       if (energy_dec) then
3428 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
3429 C     &    i,itheta,rad2deg*thetiii,
3430 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
3431 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
3432 C     &    gloc(itheta+nphi-2,icg)
3433         endif
3434       enddo
3435 C Ufff.... We've done all this!!!
3436       return
3437       end
3438 C---------------------------------------------------------------------------
3439       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3440      &     E_tc)
3441       implicit real*8 (a-h,o-z)
3442       include 'DIMENSIONS'
3443       include 'COMMON.LOCAL'
3444       include 'COMMON.IOUNITS'
3445       common /calcthet/ term1,term2,termm,diffak,ratak,
3446      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3447      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3448 C Calculate the contributions to both Gaussian lobes.
3449 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3450 C The "polynomial part" of the "standard deviation" of this part of
3451 C the distribution.
3452         sig=polthet(3,it)
3453         do j=2,0,-1
3454           sig=sig*thet_pred_mean+polthet(j,it)
3455         enddo
3456 C Derivative of the "interior part" of the "standard deviation of the"
3457 C gamma-dependent Gaussian lobe in t_c.
3458         sigtc=3*polthet(3,it)
3459         do j=2,1,-1
3460           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3461         enddo
3462         sigtc=sig*sigtc
3463 C Set the parameters of both Gaussian lobes of the distribution.
3464 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3465         fac=sig*sig+sigc0(it)
3466         sigcsq=fac+fac
3467         sigc=1.0D0/sigcsq
3468 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3469         sigsqtc=-4.0D0*sigcsq*sigtc
3470 c       print *,i,sig,sigtc,sigsqtc
3471 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3472         sigtc=-sigtc/(fac*fac)
3473 C Following variable is sigma(t_c)**(-2)
3474         sigcsq=sigcsq*sigcsq
3475         sig0i=sig0(it)
3476         sig0inv=1.0D0/sig0i**2
3477         delthec=thetai-thet_pred_mean
3478         delthe0=thetai-theta0i
3479         term1=-0.5D0*sigcsq*delthec*delthec
3480         term2=-0.5D0*sig0inv*delthe0*delthe0
3481 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3482 C NaNs in taking the logarithm. We extract the largest exponent which is added
3483 C to the energy (this being the log of the distribution) at the end of energy
3484 C term evaluation for this virtual-bond angle.
3485         if (term1.gt.term2) then
3486           termm=term1
3487           term2=dexp(term2-termm)
3488           term1=1.0d0
3489         else
3490           termm=term2
3491           term1=dexp(term1-termm)
3492           term2=1.0d0
3493         endif
3494 C The ratio between the gamma-independent and gamma-dependent lobes of
3495 C the distribution is a Gaussian function of thet_pred_mean too.
3496         diffak=gthet(2,it)-thet_pred_mean
3497         ratak=diffak/gthet(3,it)**2
3498         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3499 C Let's differentiate it in thet_pred_mean NOW.
3500         aktc=ak*ratak
3501 C Now put together the distribution terms to make complete distribution.
3502         termexp=term1+ak*term2
3503         termpre=sigc+ak*sig0i
3504 C Contribution of the bending energy from this theta is just the -log of
3505 C the sum of the contributions from the two lobes and the pre-exponential
3506 C factor. Simple enough, isn't it?
3507         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3508 C NOW the derivatives!!!
3509 C 6/6/97 Take into account the deformation.
3510         E_theta=(delthec*sigcsq*term1
3511      &       +ak*delthe0*sig0inv*term2)/termexp
3512         E_tc=((sigtc+aktc*sig0i)/termpre
3513      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3514      &       aktc*term2)/termexp)
3515       return
3516       end
3517 c-----------------------------------------------------------------------------
3518       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3519       implicit real*8 (a-h,o-z)
3520       include 'DIMENSIONS'
3521       include 'COMMON.LOCAL'
3522       include 'COMMON.IOUNITS'
3523       common /calcthet/ term1,term2,termm,diffak,ratak,
3524      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3525      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3526       delthec=thetai-thet_pred_mean
3527       delthe0=thetai-theta0i
3528 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
3529       t3 = thetai-thet_pred_mean
3530       t6 = t3**2
3531       t9 = term1
3532       t12 = t3*sigcsq
3533       t14 = t12+t6*sigsqtc
3534       t16 = 1.0d0
3535       t21 = thetai-theta0i
3536       t23 = t21**2
3537       t26 = term2
3538       t27 = t21*t26
3539       t32 = termexp
3540       t40 = t32**2
3541       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
3542      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
3543      & *(-t12*t9-ak*sig0inv*t27)
3544       return
3545       end
3546 #else
3547 C--------------------------------------------------------------------------
3548       subroutine ebend(etheta,ethetacnstr)
3549 C
3550 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3551 C angles gamma and its derivatives in consecutive thetas and gammas.
3552 C ab initio-derived potentials from
3553 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
3554 C
3555       implicit real*8 (a-h,o-z)
3556       include 'DIMENSIONS'
3557       include 'DIMENSIONS.ZSCOPT'
3558       include 'COMMON.LOCAL'
3559       include 'COMMON.GEO'
3560       include 'COMMON.INTERACT'
3561       include 'COMMON.DERIV'
3562       include 'COMMON.VAR'
3563       include 'COMMON.CHAIN'
3564       include 'COMMON.IOUNITS'
3565       include 'COMMON.NAMES'
3566       include 'COMMON.FFIELD'
3567       include 'COMMON.CONTROL'
3568       include 'COMMON.TORCNSTR'
3569       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
3570      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
3571      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
3572      & sinph1ph2(maxdouble,maxdouble)
3573       logical lprn /.false./, lprn1 /.false./
3574       etheta=0.0D0
3575 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
3576       do i=ithet_start,ithet_end
3577 c        if (itype(i-1).eq.ntyp1) cycle
3578         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
3579      &(itype(i).eq.ntyp1)) cycle
3580         if (iabs(itype(i+1)).eq.20) iblock=2
3581         if (iabs(itype(i+1)).ne.20) iblock=1
3582         dethetai=0.0d0
3583         dephii=0.0d0
3584         dephii1=0.0d0
3585         theti2=0.5d0*theta(i)
3586         ityp2=ithetyp((itype(i-1)))
3587         do k=1,nntheterm
3588           coskt(k)=dcos(k*theti2)
3589           sinkt(k)=dsin(k*theti2)
3590         enddo
3591         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
3592 #ifdef OSF
3593           phii=phi(i)
3594           if (phii.ne.phii) phii=150.0
3595 #else
3596           phii=phi(i)
3597 #endif
3598           ityp1=ithetyp((itype(i-2)))
3599           do k=1,nsingle
3600             cosph1(k)=dcos(k*phii)
3601             sinph1(k)=dsin(k*phii)
3602           enddo
3603         else
3604           phii=0.0d0
3605 c          ityp1=nthetyp+1
3606           do k=1,nsingle
3607             ityp1=ithetyp((itype(i-2)))
3608             cosph1(k)=0.0d0
3609             sinph1(k)=0.0d0
3610           enddo
3611         endif
3612         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
3613 #ifdef OSF
3614           phii1=phi(i+1)
3615           if (phii1.ne.phii1) phii1=150.0
3616           phii1=pinorm(phii1)
3617 #else
3618           phii1=phi(i+1)
3619 #endif
3620           ityp3=ithetyp((itype(i)))
3621           do k=1,nsingle
3622             cosph2(k)=dcos(k*phii1)
3623             sinph2(k)=dsin(k*phii1)
3624           enddo
3625         else
3626           phii1=0.0d0
3627 c          ityp3=nthetyp+1
3628           ityp3=ithetyp((itype(i)))
3629           do k=1,nsingle
3630             cosph2(k)=0.0d0
3631             sinph2(k)=0.0d0
3632           enddo
3633         endif
3634 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
3635 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
3636 c        call flush(iout)
3637         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
3638         do k=1,ndouble
3639           do l=1,k-1
3640             ccl=cosph1(l)*cosph2(k-l)
3641             ssl=sinph1(l)*sinph2(k-l)
3642             scl=sinph1(l)*cosph2(k-l)
3643             csl=cosph1(l)*sinph2(k-l)
3644             cosph1ph2(l,k)=ccl-ssl
3645             cosph1ph2(k,l)=ccl+ssl
3646             sinph1ph2(l,k)=scl+csl
3647             sinph1ph2(k,l)=scl-csl
3648           enddo
3649         enddo
3650         if (lprn) then
3651         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
3652      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
3653         write (iout,*) "coskt and sinkt"
3654         do k=1,nntheterm
3655           write (iout,*) k,coskt(k),sinkt(k)
3656         enddo
3657         endif
3658         do k=1,ntheterm
3659           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
3660           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
3661      &      *coskt(k)
3662           if (lprn)
3663      &    write (iout,*) "k",k,"
3664      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
3665      &     " ethetai",ethetai
3666         enddo
3667         if (lprn) then
3668         write (iout,*) "cosph and sinph"
3669         do k=1,nsingle
3670           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
3671         enddo
3672         write (iout,*) "cosph1ph2 and sinph2ph2"
3673         do k=2,ndouble
3674           do l=1,k-1
3675             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
3676      &         sinph1ph2(l,k),sinph1ph2(k,l)
3677           enddo
3678         enddo
3679         write(iout,*) "ethetai",ethetai
3680         endif
3681         do m=1,ntheterm2
3682           do k=1,nsingle
3683             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
3684      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
3685      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
3686      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
3687             ethetai=ethetai+sinkt(m)*aux
3688             dethetai=dethetai+0.5d0*m*aux*coskt(m)
3689             dephii=dephii+k*sinkt(m)*(
3690      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
3691      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
3692             dephii1=dephii1+k*sinkt(m)*(
3693      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
3694      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
3695             if (lprn)
3696      &      write (iout,*) "m",m," k",k," bbthet",
3697      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
3698      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
3699      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
3700      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
3701           enddo
3702         enddo
3703         if (lprn)
3704      &  write(iout,*) "ethetai",ethetai
3705         do m=1,ntheterm3
3706           do k=2,ndouble
3707             do l=1,k-1
3708               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
3709      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
3710      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
3711      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
3712               ethetai=ethetai+sinkt(m)*aux
3713               dethetai=dethetai+0.5d0*m*coskt(m)*aux
3714               dephii=dephii+l*sinkt(m)*(
3715      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
3716      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
3717      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
3718      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
3719               dephii1=dephii1+(k-l)*sinkt(m)*(
3720      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
3721      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
3722      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
3723      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
3724               if (lprn) then
3725               write (iout,*) "m",m," k",k," l",l," ffthet",
3726      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
3727      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
3728      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
3729      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
3730      &            " ethetai",ethetai
3731               write (iout,*) cosph1ph2(l,k)*sinkt(m),
3732      &            cosph1ph2(k,l)*sinkt(m),
3733      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
3734               endif
3735             enddo
3736           enddo
3737         enddo
3738 10      continue
3739         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
3740      &   i,theta(i)*rad2deg,phii*rad2deg,
3741      &   phii1*rad2deg,ethetai
3742         etheta=etheta+ethetai
3743         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
3744         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
3745 c        gloc(nphi+i-2,icg)=wang*dethetai
3746         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
3747       enddo
3748 C now constrains
3749       ethetacnstr=0.0d0
3750 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
3751       do i=1,ntheta_constr
3752         itheta=itheta_constr(i)
3753         thetiii=theta(itheta)
3754         difi=pinorm(thetiii-theta_constr0(i))
3755         if (difi.gt.theta_drange(i)) then
3756           difi=difi-theta_drange(i)
3757           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
3758           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
3759      &    +for_thet_constr(i)*difi**3
3760         else if (difi.lt.-drange(i)) then
3761           difi=difi+drange(i)
3762           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
3763           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
3764      &    +for_thet_constr(i)*difi**3
3765         else
3766           difi=0.0
3767         endif
3768 C       if (energy_dec) then
3769 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
3770 C     &    i,itheta,rad2deg*thetiii,
3771 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
3772 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
3773 C     &    gloc(itheta+nphi-2,icg)
3774 C        endif
3775       enddo
3776       return
3777       end
3778 #endif
3779 #ifdef CRYST_SC
3780 c-----------------------------------------------------------------------------
3781       subroutine esc(escloc)
3782 C Calculate the local energy of a side chain and its derivatives in the
3783 C corresponding virtual-bond valence angles THETA and the spherical angles
3784 C ALPHA and OMEGA.
3785       implicit real*8 (a-h,o-z)
3786       include 'DIMENSIONS'
3787       include 'DIMENSIONS.ZSCOPT'
3788       include 'COMMON.GEO'
3789       include 'COMMON.LOCAL'
3790       include 'COMMON.VAR'
3791       include 'COMMON.INTERACT'
3792       include 'COMMON.DERIV'
3793       include 'COMMON.CHAIN'
3794       include 'COMMON.IOUNITS'
3795       include 'COMMON.NAMES'
3796       include 'COMMON.FFIELD'
3797       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
3798      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
3799       common /sccalc/ time11,time12,time112,theti,it,nlobit
3800       delta=0.02d0*pi
3801       escloc=0.0D0
3802 c     write (iout,'(a)') 'ESC'
3803       do i=loc_start,loc_end
3804         it=itype(i)
3805         if (it.eq.ntyp1) cycle
3806         if (it.eq.10) goto 1
3807         nlobit=nlob(iabs(it))
3808 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
3809 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
3810         theti=theta(i+1)-pipol
3811         x(1)=dtan(theti)
3812         x(2)=alph(i)
3813         x(3)=omeg(i)
3814 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
3815
3816         if (x(2).gt.pi-delta) then
3817           xtemp(1)=x(1)
3818           xtemp(2)=pi-delta
3819           xtemp(3)=x(3)
3820           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3821           xtemp(2)=pi
3822           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3823           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
3824      &        escloci,dersc(2))
3825           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3826      &        ddersc0(1),dersc(1))
3827           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
3828      &        ddersc0(3),dersc(3))
3829           xtemp(2)=pi-delta
3830           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3831           xtemp(2)=pi
3832           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3833           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
3834      &            dersc0(2),esclocbi,dersc02)
3835           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3836      &            dersc12,dersc01)
3837           call splinthet(x(2),0.5d0*delta,ss,ssd)
3838           dersc0(1)=dersc01
3839           dersc0(2)=dersc02
3840           dersc0(3)=0.0d0
3841           do k=1,3
3842             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3843           enddo
3844           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3845 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3846 c    &             esclocbi,ss,ssd
3847           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3848 c         escloci=esclocbi
3849 c         write (iout,*) escloci
3850         else if (x(2).lt.delta) then
3851           xtemp(1)=x(1)
3852           xtemp(2)=delta
3853           xtemp(3)=x(3)
3854           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3855           xtemp(2)=0.0d0
3856           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3857           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
3858      &        escloci,dersc(2))
3859           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3860      &        ddersc0(1),dersc(1))
3861           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
3862      &        ddersc0(3),dersc(3))
3863           xtemp(2)=delta
3864           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3865           xtemp(2)=0.0d0
3866           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3867           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
3868      &            dersc0(2),esclocbi,dersc02)
3869           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3870      &            dersc12,dersc01)
3871           dersc0(1)=dersc01
3872           dersc0(2)=dersc02
3873           dersc0(3)=0.0d0
3874           call splinthet(x(2),0.5d0*delta,ss,ssd)
3875           do k=1,3
3876             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3877           enddo
3878           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3879 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3880 c    &             esclocbi,ss,ssd
3881           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3882 c         write (iout,*) escloci
3883         else
3884           call enesc(x,escloci,dersc,ddummy,.false.)
3885         endif
3886
3887         escloc=escloc+escloci
3888 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
3889
3890         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3891      &   wscloc*dersc(1)
3892         gloc(ialph(i,1),icg)=wscloc*dersc(2)
3893         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
3894     1   continue
3895       enddo
3896       return
3897       end
3898 C---------------------------------------------------------------------------
3899       subroutine enesc(x,escloci,dersc,ddersc,mixed)
3900       implicit real*8 (a-h,o-z)
3901       include 'DIMENSIONS'
3902       include 'COMMON.GEO'
3903       include 'COMMON.LOCAL'
3904       include 'COMMON.IOUNITS'
3905       common /sccalc/ time11,time12,time112,theti,it,nlobit
3906       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
3907       double precision contr(maxlob,-1:1)
3908       logical mixed
3909 c       write (iout,*) 'it=',it,' nlobit=',nlobit
3910         escloc_i=0.0D0
3911         do j=1,3
3912           dersc(j)=0.0D0
3913           if (mixed) ddersc(j)=0.0d0
3914         enddo
3915         x3=x(3)
3916
3917 C Because of periodicity of the dependence of the SC energy in omega we have
3918 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
3919 C To avoid underflows, first compute & store the exponents.
3920
3921         do iii=-1,1
3922
3923           x(3)=x3+iii*dwapi
3924
3925           do j=1,nlobit
3926             do k=1,3
3927               z(k)=x(k)-censc(k,j,it)
3928             enddo
3929             do k=1,3
3930               Axk=0.0D0
3931               do l=1,3
3932                 Axk=Axk+gaussc(l,k,j,it)*z(l)
3933               enddo
3934               Ax(k,j,iii)=Axk
3935             enddo
3936             expfac=0.0D0
3937             do k=1,3
3938               expfac=expfac+Ax(k,j,iii)*z(k)
3939             enddo
3940             contr(j,iii)=expfac
3941           enddo ! j
3942
3943         enddo ! iii
3944
3945         x(3)=x3
3946 C As in the case of ebend, we want to avoid underflows in exponentiation and
3947 C subsequent NaNs and INFs in energy calculation.
3948 C Find the largest exponent
3949         emin=contr(1,-1)
3950         do iii=-1,1
3951           do j=1,nlobit
3952             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
3953           enddo
3954         enddo
3955         emin=0.5D0*emin
3956 cd      print *,'it=',it,' emin=',emin
3957
3958 C Compute the contribution to SC energy and derivatives
3959         do iii=-1,1
3960
3961           do j=1,nlobit
3962             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
3963 cd          print *,'j=',j,' expfac=',expfac
3964             escloc_i=escloc_i+expfac
3965             do k=1,3
3966               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
3967             enddo
3968             if (mixed) then
3969               do k=1,3,2
3970                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
3971      &            +gaussc(k,2,j,it))*expfac
3972               enddo
3973             endif
3974           enddo
3975
3976         enddo ! iii
3977
3978         dersc(1)=dersc(1)/cos(theti)**2
3979         ddersc(1)=ddersc(1)/cos(theti)**2
3980         ddersc(3)=ddersc(3)
3981
3982         escloci=-(dlog(escloc_i)-emin)
3983         do j=1,3
3984           dersc(j)=dersc(j)/escloc_i
3985         enddo
3986         if (mixed) then
3987           do j=1,3,2
3988             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
3989           enddo
3990         endif
3991       return
3992       end
3993 C------------------------------------------------------------------------------
3994       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
3995       implicit real*8 (a-h,o-z)
3996       include 'DIMENSIONS'
3997       include 'COMMON.GEO'
3998       include 'COMMON.LOCAL'
3999       include 'COMMON.IOUNITS'
4000       common /sccalc/ time11,time12,time112,theti,it,nlobit
4001       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4002       double precision contr(maxlob)
4003       logical mixed
4004
4005       escloc_i=0.0D0
4006
4007       do j=1,3
4008         dersc(j)=0.0D0
4009       enddo
4010
4011       do j=1,nlobit
4012         do k=1,2
4013           z(k)=x(k)-censc(k,j,it)
4014         enddo
4015         z(3)=dwapi
4016         do k=1,3
4017           Axk=0.0D0
4018           do l=1,3
4019             Axk=Axk+gaussc(l,k,j,it)*z(l)
4020           enddo
4021           Ax(k,j)=Axk
4022         enddo
4023         expfac=0.0D0
4024         do k=1,3
4025           expfac=expfac+Ax(k,j)*z(k)
4026         enddo
4027         contr(j)=expfac
4028       enddo ! j
4029
4030 C As in the case of ebend, we want to avoid underflows in exponentiation and
4031 C subsequent NaNs and INFs in energy calculation.
4032 C Find the largest exponent
4033       emin=contr(1)
4034       do j=1,nlobit
4035         if (emin.gt.contr(j)) emin=contr(j)
4036       enddo
4037       emin=0.5D0*emin
4038
4039 C Compute the contribution to SC energy and derivatives
4040
4041       dersc12=0.0d0
4042       do j=1,nlobit
4043         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4044         escloc_i=escloc_i+expfac
4045         do k=1,2
4046           dersc(k)=dersc(k)+Ax(k,j)*expfac
4047         enddo
4048         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4049      &            +gaussc(1,2,j,it))*expfac
4050         dersc(3)=0.0d0
4051       enddo
4052
4053       dersc(1)=dersc(1)/cos(theti)**2
4054       dersc12=dersc12/cos(theti)**2
4055       escloci=-(dlog(escloc_i)-emin)
4056       do j=1,2
4057         dersc(j)=dersc(j)/escloc_i
4058       enddo
4059       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4060       return
4061       end
4062 #else
4063 c----------------------------------------------------------------------------------
4064       subroutine esc(escloc)
4065 C Calculate the local energy of a side chain and its derivatives in the
4066 C corresponding virtual-bond valence angles THETA and the spherical angles
4067 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4068 C added by Urszula Kozlowska. 07/11/2007
4069 C
4070       implicit real*8 (a-h,o-z)
4071       include 'DIMENSIONS'
4072       include 'DIMENSIONS.ZSCOPT'
4073       include 'COMMON.GEO'
4074       include 'COMMON.LOCAL'
4075       include 'COMMON.VAR'
4076       include 'COMMON.SCROT'
4077       include 'COMMON.INTERACT'
4078       include 'COMMON.DERIV'
4079       include 'COMMON.CHAIN'
4080       include 'COMMON.IOUNITS'
4081       include 'COMMON.NAMES'
4082       include 'COMMON.FFIELD'
4083       include 'COMMON.CONTROL'
4084       include 'COMMON.VECTORS'
4085       double precision x_prime(3),y_prime(3),z_prime(3)
4086      &    , sumene,dsc_i,dp2_i,x(65),
4087      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4088      &    de_dxx,de_dyy,de_dzz,de_dt
4089       double precision s1_t,s1_6_t,s2_t,s2_6_t
4090       double precision
4091      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4092      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4093      & dt_dCi(3),dt_dCi1(3)
4094       common /sccalc/ time11,time12,time112,theti,it,nlobit
4095       delta=0.02d0*pi
4096       escloc=0.0D0
4097       do i=loc_start,loc_end
4098         if (itype(i).eq.ntyp1) cycle
4099         costtab(i+1) =dcos(theta(i+1))
4100         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4101         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4102         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4103         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4104         cosfac=dsqrt(cosfac2)
4105         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4106         sinfac=dsqrt(sinfac2)
4107         it=iabs(itype(i))
4108         if (it.eq.10) goto 1
4109 c
4110 C  Compute the axes of tghe local cartesian coordinates system; store in
4111 c   x_prime, y_prime and z_prime
4112 c
4113         do j=1,3
4114           x_prime(j) = 0.00
4115           y_prime(j) = 0.00
4116           z_prime(j) = 0.00
4117         enddo
4118 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4119 C     &   dc_norm(3,i+nres)
4120         do j = 1,3
4121           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4122           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4123         enddo
4124         do j = 1,3
4125           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
4126         enddo
4127 c       write (2,*) "i",i
4128 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4129 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4130 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4131 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4132 c      & " xy",scalar(x_prime(1),y_prime(1)),
4133 c      & " xz",scalar(x_prime(1),z_prime(1)),
4134 c      & " yy",scalar(y_prime(1),y_prime(1)),
4135 c      & " yz",scalar(y_prime(1),z_prime(1)),
4136 c      & " zz",scalar(z_prime(1),z_prime(1))
4137 c
4138 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4139 C to local coordinate system. Store in xx, yy, zz.
4140 c
4141         xx=0.0d0
4142         yy=0.0d0
4143         zz=0.0d0
4144         do j = 1,3
4145           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4146           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4147           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4148         enddo
4149
4150         xxtab(i)=xx
4151         yytab(i)=yy
4152         zztab(i)=zz
4153 C
4154 C Compute the energy of the ith side cbain
4155 C
4156 c        write (2,*) "xx",xx," yy",yy," zz",zz
4157         it=iabs(itype(i))
4158         do j = 1,65
4159           x(j) = sc_parmin(j,it)
4160         enddo
4161 #ifdef CHECK_COORD
4162 Cc diagnostics - remove later
4163         xx1 = dcos(alph(2))
4164         yy1 = dsin(alph(2))*dcos(omeg(2))
4165         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
4166         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4167      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4168      &    xx1,yy1,zz1
4169 C,"  --- ", xx_w,yy_w,zz_w
4170 c end diagnostics
4171 #endif
4172         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4173      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4174      &   + x(10)*yy*zz
4175         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4176      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4177      & + x(20)*yy*zz
4178         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4179      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4180      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4181      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4182      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4183      &  +x(40)*xx*yy*zz
4184         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4185      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4186      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4187      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4188      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4189      &  +x(60)*xx*yy*zz
4190         dsc_i   = 0.743d0+x(61)
4191         dp2_i   = 1.9d0+x(62)
4192         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4193      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4194         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4195      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4196         s1=(1+x(63))/(0.1d0 + dscp1)
4197         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4198         s2=(1+x(65))/(0.1d0 + dscp2)
4199         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4200         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4201      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4202 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4203 c     &   sumene4,
4204 c     &   dscp1,dscp2,sumene
4205 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4206         escloc = escloc + sumene
4207 c        write (2,*) "escloc",escloc
4208 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
4209 c     &  zz,xx,yy
4210         if (.not. calc_grad) goto 1
4211 #ifdef DEBUG
4212 C
4213 C This section to check the numerical derivatives of the energy of ith side
4214 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4215 C #define DEBUG in the code to turn it on.
4216 C
4217         write (2,*) "sumene               =",sumene
4218         aincr=1.0d-7
4219         xxsave=xx
4220         xx=xx+aincr
4221         write (2,*) xx,yy,zz
4222         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4223         de_dxx_num=(sumenep-sumene)/aincr
4224         xx=xxsave
4225         write (2,*) "xx+ sumene from enesc=",sumenep
4226         yysave=yy
4227         yy=yy+aincr
4228         write (2,*) xx,yy,zz
4229         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4230         de_dyy_num=(sumenep-sumene)/aincr
4231         yy=yysave
4232         write (2,*) "yy+ sumene from enesc=",sumenep
4233         zzsave=zz
4234         zz=zz+aincr
4235         write (2,*) xx,yy,zz
4236         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4237         de_dzz_num=(sumenep-sumene)/aincr
4238         zz=zzsave
4239         write (2,*) "zz+ sumene from enesc=",sumenep
4240         costsave=cost2tab(i+1)
4241         sintsave=sint2tab(i+1)
4242         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4243         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4244         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4245         de_dt_num=(sumenep-sumene)/aincr
4246         write (2,*) " t+ sumene from enesc=",sumenep
4247         cost2tab(i+1)=costsave
4248         sint2tab(i+1)=sintsave
4249 C End of diagnostics section.
4250 #endif
4251 C
4252 C Compute the gradient of esc
4253 C
4254         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4255         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4256         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4257         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4258         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4259         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4260         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4261         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4262         pom1=(sumene3*sint2tab(i+1)+sumene1)
4263      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4264         pom2=(sumene4*cost2tab(i+1)+sumene2)
4265      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4266         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4267         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4268      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4269      &  +x(40)*yy*zz
4270         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4271         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4272      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4273      &  +x(60)*yy*zz
4274         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4275      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4276      &        +(pom1+pom2)*pom_dx
4277 #ifdef DEBUG
4278         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4279 #endif
4280 C
4281         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4282         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4283      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4284      &  +x(40)*xx*zz
4285         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4286         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4287      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4288      &  +x(59)*zz**2 +x(60)*xx*zz
4289         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4290      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4291      &        +(pom1-pom2)*pom_dy
4292 #ifdef DEBUG
4293         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4294 #endif
4295 C
4296         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4297      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4298      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4299      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4300      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4301      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4302      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4303      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4304 #ifdef DEBUG
4305         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4306 #endif
4307 C
4308         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4309      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4310      &  +pom1*pom_dt1+pom2*pom_dt2
4311 #ifdef DEBUG
4312         write(2,*), "de_dt = ", de_dt,de_dt_num
4313 #endif
4314 c
4315 C
4316        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4317        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4318        cosfac2xx=cosfac2*xx
4319        sinfac2yy=sinfac2*yy
4320        do k = 1,3
4321          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4322      &      vbld_inv(i+1)
4323          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4324      &      vbld_inv(i)
4325          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4326          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4327 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4328 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4329 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4330 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4331          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4332          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4333          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4334          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4335          dZZ_Ci1(k)=0.0d0
4336          dZZ_Ci(k)=0.0d0
4337          do j=1,3
4338            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
4339      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
4340            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
4341      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
4342          enddo
4343
4344          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4345          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4346          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4347 c
4348          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4349          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4350        enddo
4351
4352        do k=1,3
4353          dXX_Ctab(k,i)=dXX_Ci(k)
4354          dXX_C1tab(k,i)=dXX_Ci1(k)
4355          dYY_Ctab(k,i)=dYY_Ci(k)
4356          dYY_C1tab(k,i)=dYY_Ci1(k)
4357          dZZ_Ctab(k,i)=dZZ_Ci(k)
4358          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4359          dXX_XYZtab(k,i)=dXX_XYZ(k)
4360          dYY_XYZtab(k,i)=dYY_XYZ(k)
4361          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4362        enddo
4363
4364        do k = 1,3
4365 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4366 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4367 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4368 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4369 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4370 c     &    dt_dci(k)
4371 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4372 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4373          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4374      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4375          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4376      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4377          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4378      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4379        enddo
4380 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4381 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4382
4383 C to check gradient call subroutine check_grad
4384
4385     1 continue
4386       enddo
4387       return
4388       end
4389 #endif
4390 c------------------------------------------------------------------------------
4391       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4392 C
4393 C This procedure calculates two-body contact function g(rij) and its derivative:
4394 C
4395 C           eps0ij                                     !       x < -1
4396 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4397 C            0                                         !       x > 1
4398 C
4399 C where x=(rij-r0ij)/delta
4400 C
4401 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4402 C
4403       implicit none
4404       double precision rij,r0ij,eps0ij,fcont,fprimcont
4405       double precision x,x2,x4,delta
4406 c     delta=0.02D0*r0ij
4407 c      delta=0.2D0*r0ij
4408       x=(rij-r0ij)/delta
4409       if (x.lt.-1.0D0) then
4410         fcont=eps0ij
4411         fprimcont=0.0D0
4412       else if (x.le.1.0D0) then
4413         x2=x*x
4414         x4=x2*x2
4415         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4416         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4417       else
4418         fcont=0.0D0
4419         fprimcont=0.0D0
4420       endif
4421       return
4422       end
4423 c------------------------------------------------------------------------------
4424       subroutine splinthet(theti,delta,ss,ssder)
4425       implicit real*8 (a-h,o-z)
4426       include 'DIMENSIONS'
4427       include 'DIMENSIONS.ZSCOPT'
4428       include 'COMMON.VAR'
4429       include 'COMMON.GEO'
4430       thetup=pi-delta
4431       thetlow=delta
4432       if (theti.gt.pipol) then
4433         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4434       else
4435         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4436         ssder=-ssder
4437       endif
4438       return
4439       end
4440 c------------------------------------------------------------------------------
4441       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4442       implicit none
4443       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4444       double precision ksi,ksi2,ksi3,a1,a2,a3
4445       a1=fprim0*delta/(f1-f0)
4446       a2=3.0d0-2.0d0*a1
4447       a3=a1-2.0d0
4448       ksi=(x-x0)/delta
4449       ksi2=ksi*ksi
4450       ksi3=ksi2*ksi
4451       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4452       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4453       return
4454       end
4455 c------------------------------------------------------------------------------
4456       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4457       implicit none
4458       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4459       double precision ksi,ksi2,ksi3,a1,a2,a3
4460       ksi=(x-x0)/delta
4461       ksi2=ksi*ksi
4462       ksi3=ksi2*ksi
4463       a1=fprim0x*delta
4464       a2=3*(f1x-f0x)-2*fprim0x*delta
4465       a3=fprim0x*delta-2*(f1x-f0x)
4466       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4467       return
4468       end
4469 C-----------------------------------------------------------------------------
4470 #ifdef CRYST_TOR
4471 C-----------------------------------------------------------------------------
4472       subroutine etor(etors,edihcnstr,fact)
4473       implicit real*8 (a-h,o-z)
4474       include 'DIMENSIONS'
4475       include 'DIMENSIONS.ZSCOPT'
4476       include 'COMMON.VAR'
4477       include 'COMMON.GEO'
4478       include 'COMMON.LOCAL'
4479       include 'COMMON.TORSION'
4480       include 'COMMON.INTERACT'
4481       include 'COMMON.DERIV'
4482       include 'COMMON.CHAIN'
4483       include 'COMMON.NAMES'
4484       include 'COMMON.IOUNITS'
4485       include 'COMMON.FFIELD'
4486       include 'COMMON.TORCNSTR'
4487       logical lprn
4488 C Set lprn=.true. for debugging
4489       lprn=.false.
4490 c      lprn=.true.
4491       etors=0.0D0
4492       do i=iphi_start,iphi_end
4493         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
4494      &      .or. itype(i).eq.ntyp1) cycle
4495         itori=itortyp(itype(i-2))
4496         itori1=itortyp(itype(i-1))
4497         phii=phi(i)
4498         gloci=0.0D0
4499 C Proline-Proline pair is a special case...
4500         if (itori.eq.3 .and. itori1.eq.3) then
4501           if (phii.gt.-dwapi3) then
4502             cosphi=dcos(3*phii)
4503             fac=1.0D0/(1.0D0-cosphi)
4504             etorsi=v1(1,3,3)*fac
4505             etorsi=etorsi+etorsi
4506             etors=etors+etorsi-v1(1,3,3)
4507             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4508           endif
4509           do j=1,3
4510             v1ij=v1(j+1,itori,itori1)
4511             v2ij=v2(j+1,itori,itori1)
4512             cosphi=dcos(j*phii)
4513             sinphi=dsin(j*phii)
4514             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4515             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4516           enddo
4517         else
4518           do j=1,nterm_old
4519             v1ij=v1(j,itori,itori1)
4520             v2ij=v2(j,itori,itori1)
4521             cosphi=dcos(j*phii)
4522             sinphi=dsin(j*phii)
4523             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4524             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4525           enddo
4526         endif
4527         if (lprn)
4528      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4529      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4530      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4531         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4532 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4533       enddo
4534 ! 6/20/98 - dihedral angle constraints
4535       edihcnstr=0.0d0
4536       do i=1,ndih_constr
4537         itori=idih_constr(i)
4538         phii=phi(itori)
4539         difi=phii-phi0(i)
4540         if (difi.gt.drange(i)) then
4541           difi=difi-drange(i)
4542           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4543           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4544         else if (difi.lt.-drange(i)) then
4545           difi=difi+drange(i)
4546           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4547           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4548         endif
4549 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
4550 C     &    i,itori,rad2deg*phii,
4551 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
4552       enddo
4553 !      write (iout,*) 'edihcnstr',edihcnstr
4554       return
4555       end
4556 c------------------------------------------------------------------------------
4557 #else
4558       subroutine etor(etors,edihcnstr,fact)
4559       implicit real*8 (a-h,o-z)
4560       include 'DIMENSIONS'
4561       include 'DIMENSIONS.ZSCOPT'
4562       include 'COMMON.VAR'
4563       include 'COMMON.GEO'
4564       include 'COMMON.LOCAL'
4565       include 'COMMON.TORSION'
4566       include 'COMMON.INTERACT'
4567       include 'COMMON.DERIV'
4568       include 'COMMON.CHAIN'
4569       include 'COMMON.NAMES'
4570       include 'COMMON.IOUNITS'
4571       include 'COMMON.FFIELD'
4572       include 'COMMON.TORCNSTR'
4573       logical lprn
4574 C Set lprn=.true. for debugging
4575       lprn=.false.
4576 c      lprn=.true.
4577       etors=0.0D0
4578       do i=iphi_start,iphi_end
4579         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
4580      &       .or. itype(i).eq.ntyp1) cycle
4581         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4582          if (iabs(itype(i)).eq.20) then
4583          iblock=2
4584          else
4585          iblock=1
4586          endif
4587         itori=itortyp(itype(i-2))
4588         itori1=itortyp(itype(i-1))
4589         phii=phi(i)
4590         gloci=0.0D0
4591 C Regular cosine and sine terms
4592         do j=1,nterm(itori,itori1,iblock)
4593           v1ij=v1(j,itori,itori1,iblock)
4594           v2ij=v2(j,itori,itori1,iblock)
4595           cosphi=dcos(j*phii)
4596           sinphi=dsin(j*phii)
4597           etors=etors+v1ij*cosphi+v2ij*sinphi
4598           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4599         enddo
4600 C Lorentz terms
4601 C                         v1
4602 C  E = SUM ----------------------------------- - v1
4603 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4604 C
4605         cosphi=dcos(0.5d0*phii)
4606         sinphi=dsin(0.5d0*phii)
4607         do j=1,nlor(itori,itori1,iblock)
4608           vl1ij=vlor1(j,itori,itori1)
4609           vl2ij=vlor2(j,itori,itori1)
4610           vl3ij=vlor3(j,itori,itori1)
4611           pom=vl2ij*cosphi+vl3ij*sinphi
4612           pom1=1.0d0/(pom*pom+1.0d0)
4613           etors=etors+vl1ij*pom1
4614 c          if (energy_dec) etors_ii=etors_ii+
4615 c     &                vl1ij*pom1
4616           pom=-pom*pom1*pom1
4617           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4618         enddo
4619 C Subtract the constant term
4620         etors=etors-v0(itori,itori1,iblock)
4621         if (lprn)
4622      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4623      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4624      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
4625         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4626 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4627  1215   continue
4628       enddo
4629 ! 6/20/98 - dihedral angle constraints
4630       edihcnstr=0.0d0
4631       do i=1,ndih_constr
4632         itori=idih_constr(i)
4633         phii=phi(itori)
4634         difi=pinorm(phii-phi0(i))
4635         edihi=0.0d0
4636         if (difi.gt.drange(i)) then
4637           difi=difi-drange(i)
4638           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4639           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4640           edihi=0.25d0*ftors(i)*difi**4
4641         else if (difi.lt.-drange(i)) then
4642           difi=difi+drange(i)
4643           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
4644           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
4645           edihi=0.25d0*ftors(i)*difi**4
4646         else
4647           difi=0.0d0
4648         endif
4649         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
4650      &    i,itori,rad2deg*phii,
4651      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
4652 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
4653 c     &    drange(i),edihi
4654 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4655 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
4656       enddo
4657 !      write (iout,*) 'edihcnstr',edihcnstr
4658       return
4659       end
4660 c----------------------------------------------------------------------------
4661       subroutine etor_d(etors_d,fact2)
4662 C 6/23/01 Compute double torsional energy
4663       implicit real*8 (a-h,o-z)
4664       include 'DIMENSIONS'
4665       include 'DIMENSIONS.ZSCOPT'
4666       include 'COMMON.VAR'
4667       include 'COMMON.GEO'
4668       include 'COMMON.LOCAL'
4669       include 'COMMON.TORSION'
4670       include 'COMMON.INTERACT'
4671       include 'COMMON.DERIV'
4672       include 'COMMON.CHAIN'
4673       include 'COMMON.NAMES'
4674       include 'COMMON.IOUNITS'
4675       include 'COMMON.FFIELD'
4676       include 'COMMON.TORCNSTR'
4677       logical lprn
4678 C Set lprn=.true. for debugging
4679       lprn=.false.
4680 c     lprn=.true.
4681       etors_d=0.0D0
4682       do i=iphi_start,iphi_end-1
4683         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
4684      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4685         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
4686      &     goto 1215
4687         itori=itortyp(itype(i-2))
4688         itori1=itortyp(itype(i-1))
4689         itori2=itortyp(itype(i))
4690         phii=phi(i)
4691         phii1=phi(i+1)
4692         gloci1=0.0D0
4693         gloci2=0.0D0
4694         iblock=1
4695         if (iabs(itype(i+1)).eq.20) iblock=2
4696 C Regular cosine and sine terms
4697         do j=1,ntermd_1(itori,itori1,itori2,iblock)
4698           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
4699           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
4700           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
4701           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
4702           cosphi1=dcos(j*phii)
4703           sinphi1=dsin(j*phii)
4704           cosphi2=dcos(j*phii1)
4705           sinphi2=dsin(j*phii1)
4706           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
4707      &     v2cij*cosphi2+v2sij*sinphi2
4708           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
4709           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
4710         enddo
4711         do k=2,ntermd_2(itori,itori1,itori2,iblock)
4712           do l=1,k-1
4713             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
4714             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
4715             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
4716             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
4717             cosphi1p2=dcos(l*phii+(k-l)*phii1)
4718             cosphi1m2=dcos(l*phii-(k-l)*phii1)
4719             sinphi1p2=dsin(l*phii+(k-l)*phii1)
4720             sinphi1m2=dsin(l*phii-(k-l)*phii1)
4721             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
4722      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
4723             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
4724      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
4725             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
4726      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
4727           enddo
4728         enddo
4729         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
4730         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
4731  1215   continue
4732       enddo
4733       return
4734       end
4735 #endif
4736 c------------------------------------------------------------------------------
4737       subroutine eback_sc_corr(esccor)
4738 c 7/21/2007 Correlations between the backbone-local and side-chain-local
4739 c        conformational states; temporarily implemented as differences
4740 c        between UNRES torsional potentials (dependent on three types of
4741 c        residues) and the torsional potentials dependent on all 20 types
4742 c        of residues computed from AM1 energy surfaces of terminally-blocked
4743 c        amino-acid residues.
4744       implicit real*8 (a-h,o-z)
4745       include 'DIMENSIONS'
4746       include 'DIMENSIONS.ZSCOPT'
4747       include 'COMMON.VAR'
4748       include 'COMMON.GEO'
4749       include 'COMMON.LOCAL'
4750       include 'COMMON.TORSION'
4751       include 'COMMON.SCCOR'
4752       include 'COMMON.INTERACT'
4753       include 'COMMON.DERIV'
4754       include 'COMMON.CHAIN'
4755       include 'COMMON.NAMES'
4756       include 'COMMON.IOUNITS'
4757       include 'COMMON.FFIELD'
4758       include 'COMMON.CONTROL'
4759       logical lprn
4760 C Set lprn=.true. for debugging
4761       lprn=.false.
4762 c      lprn=.true.
4763 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
4764       esccor=0.0D0
4765       do i=itau_start,itau_end
4766         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
4767         esccor_ii=0.0D0
4768         isccori=isccortyp(itype(i-2))
4769         isccori1=isccortyp(itype(i-1))
4770         phii=phi(i)
4771         do intertyp=1,3 !intertyp
4772 cc Added 09 May 2012 (Adasko)
4773 cc  Intertyp means interaction type of backbone mainchain correlation:
4774 c   1 = SC...Ca...Ca...Ca
4775 c   2 = Ca...Ca...Ca...SC
4776 c   3 = SC...Ca...Ca...SCi
4777         gloci=0.0D0
4778         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
4779      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
4780      &      (itype(i-1).eq.ntyp1)))
4781      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
4782      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
4783      &     .or.(itype(i).eq.ntyp1)))
4784      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
4785      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4786      &      (itype(i-3).eq.ntyp1)))) cycle
4787         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
4788         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
4789      & cycle
4790        do j=1,nterm_sccor(isccori,isccori1)
4791           v1ij=v1sccor(j,intertyp,isccori,isccori1)
4792           v2ij=v2sccor(j,intertyp,isccori,isccori1)
4793           cosphi=dcos(j*tauangle(intertyp,i))
4794           sinphi=dsin(j*tauangle(intertyp,i))
4795            esccor=esccor+v1ij*cosphi+v2ij*sinphi
4796            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4797          enddo
4798 C      write (iout,*)"EBACK_SC_COR",esccor,i
4799 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
4800 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
4801 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
4802         if (lprn)
4803      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4804      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4805      &  (v1sccor(j,1,itori,itori1),j=1,6)
4806      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
4807 c        gsccor_loc(i-3)=gloci
4808        enddo !intertyp
4809       enddo
4810       return
4811       end
4812 c------------------------------------------------------------------------------
4813       subroutine multibody(ecorr)
4814 C This subroutine calculates multi-body contributions to energy following
4815 C the idea of Skolnick et al. If side chains I and J make a contact and
4816 C at the same time side chains I+1 and J+1 make a contact, an extra
4817 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
4818       implicit real*8 (a-h,o-z)
4819       include 'DIMENSIONS'
4820       include 'COMMON.IOUNITS'
4821       include 'COMMON.DERIV'
4822       include 'COMMON.INTERACT'
4823       include 'COMMON.CONTACTS'
4824       double precision gx(3),gx1(3)
4825       logical lprn
4826
4827 C Set lprn=.true. for debugging
4828       lprn=.false.
4829
4830       if (lprn) then
4831         write (iout,'(a)') 'Contact function values:'
4832         do i=nnt,nct-2
4833           write (iout,'(i2,20(1x,i2,f10.5))')
4834      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
4835         enddo
4836       endif
4837       ecorr=0.0D0
4838       do i=nnt,nct
4839         do j=1,3
4840           gradcorr(j,i)=0.0D0
4841           gradxorr(j,i)=0.0D0
4842         enddo
4843       enddo
4844       do i=nnt,nct-2
4845
4846         DO ISHIFT = 3,4
4847
4848         i1=i+ishift
4849         num_conti=num_cont(i)
4850         num_conti1=num_cont(i1)
4851         do jj=1,num_conti
4852           j=jcont(jj,i)
4853           do kk=1,num_conti1
4854             j1=jcont(kk,i1)
4855             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
4856 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4857 cd   &                   ' ishift=',ishift
4858 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
4859 C The system gains extra energy.
4860               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
4861             endif   ! j1==j+-ishift
4862           enddo     ! kk
4863         enddo       ! jj
4864
4865         ENDDO ! ISHIFT
4866
4867       enddo         ! i
4868       return
4869       end
4870 c------------------------------------------------------------------------------
4871       double precision function esccorr(i,j,k,l,jj,kk)
4872       implicit real*8 (a-h,o-z)
4873       include 'DIMENSIONS'
4874       include 'COMMON.IOUNITS'
4875       include 'COMMON.DERIV'
4876       include 'COMMON.INTERACT'
4877       include 'COMMON.CONTACTS'
4878       double precision gx(3),gx1(3)
4879       logical lprn
4880       lprn=.false.
4881       eij=facont(jj,i)
4882       ekl=facont(kk,k)
4883 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
4884 C Calculate the multi-body contribution to energy.
4885 C Calculate multi-body contributions to the gradient.
4886 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
4887 cd   & k,l,(gacont(m,kk,k),m=1,3)
4888       do m=1,3
4889         gx(m) =ekl*gacont(m,jj,i)
4890         gx1(m)=eij*gacont(m,kk,k)
4891         gradxorr(m,i)=gradxorr(m,i)-gx(m)
4892         gradxorr(m,j)=gradxorr(m,j)+gx(m)
4893         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
4894         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
4895       enddo
4896       do m=i,j-1
4897         do ll=1,3
4898           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
4899         enddo
4900       enddo
4901       do m=k,l-1
4902         do ll=1,3
4903           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
4904         enddo
4905       enddo
4906       esccorr=-eij*ekl
4907       return
4908       end
4909 c------------------------------------------------------------------------------
4910 #ifdef MPL
4911       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
4912       implicit real*8 (a-h,o-z)
4913       include 'DIMENSIONS'
4914       integer dimen1,dimen2,atom,indx
4915       double precision buffer(dimen1,dimen2)
4916       double precision zapas
4917       common /contacts_hb/ zapas(3,ntyp,maxres,7),
4918      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
4919      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
4920       num_kont=num_cont_hb(atom)
4921       do i=1,num_kont
4922         do k=1,7
4923           do j=1,3
4924             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
4925           enddo ! j
4926         enddo ! k
4927         buffer(i,indx+22)=facont_hb(i,atom)
4928         buffer(i,indx+23)=ees0p(i,atom)
4929         buffer(i,indx+24)=ees0m(i,atom)
4930         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
4931       enddo ! i
4932       buffer(1,indx+26)=dfloat(num_kont)
4933       return
4934       end
4935 c------------------------------------------------------------------------------
4936       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
4937       implicit real*8 (a-h,o-z)
4938       include 'DIMENSIONS'
4939       integer dimen1,dimen2,atom,indx
4940       double precision buffer(dimen1,dimen2)
4941       double precision zapas
4942       common /contacts_hb/ zapas(3,ntyp,maxres,7),
4943      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
4944      &         ees0m(ntyp,maxres),
4945      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
4946       num_kont=buffer(1,indx+26)
4947       num_kont_old=num_cont_hb(atom)
4948       num_cont_hb(atom)=num_kont+num_kont_old
4949       do i=1,num_kont
4950         ii=i+num_kont_old
4951         do k=1,7
4952           do j=1,3
4953             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
4954           enddo ! j
4955         enddo ! k
4956         facont_hb(ii,atom)=buffer(i,indx+22)
4957         ees0p(ii,atom)=buffer(i,indx+23)
4958         ees0m(ii,atom)=buffer(i,indx+24)
4959         jcont_hb(ii,atom)=buffer(i,indx+25)
4960       enddo ! i
4961       return
4962       end
4963 c------------------------------------------------------------------------------
4964 #endif
4965       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
4966 C This subroutine calculates multi-body contributions to hydrogen-bonding
4967       implicit real*8 (a-h,o-z)
4968       include 'DIMENSIONS'
4969       include 'DIMENSIONS.ZSCOPT'
4970       include 'COMMON.IOUNITS'
4971 #ifdef MPL
4972       include 'COMMON.INFO'
4973 #endif
4974       include 'COMMON.FFIELD'
4975       include 'COMMON.DERIV'
4976       include 'COMMON.INTERACT'
4977       include 'COMMON.CONTACTS'
4978 #ifdef MPL
4979       parameter (max_cont=maxconts)
4980       parameter (max_dim=2*(8*3+2))
4981       parameter (msglen1=max_cont*max_dim*4)
4982       parameter (msglen2=2*msglen1)
4983       integer source,CorrelType,CorrelID,Error
4984       double precision buffer(max_cont,max_dim)
4985 #endif
4986       double precision gx(3),gx1(3)
4987       logical lprn,ldone
4988
4989 C Set lprn=.true. for debugging
4990       lprn=.false.
4991 #ifdef MPL
4992       n_corr=0
4993       n_corr1=0
4994       if (fgProcs.le.1) goto 30
4995       if (lprn) then
4996         write (iout,'(a)') 'Contact function values:'
4997         do i=nnt,nct-2
4998           write (iout,'(2i3,50(1x,i2,f5.2))')
4999      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5000      &    j=1,num_cont_hb(i))
5001         enddo
5002       endif
5003 C Caution! Following code assumes that electrostatic interactions concerning
5004 C a given atom are split among at most two processors!
5005       CorrelType=477
5006       CorrelID=MyID+1
5007       ldone=.false.
5008       do i=1,max_cont
5009         do j=1,max_dim
5010           buffer(i,j)=0.0D0
5011         enddo
5012       enddo
5013       mm=mod(MyRank,2)
5014 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5015       if (mm) 20,20,10
5016    10 continue
5017 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5018       if (MyRank.gt.0) then
5019 C Send correlation contributions to the preceding processor
5020         msglen=msglen1
5021         nn=num_cont_hb(iatel_s)
5022         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5023 cd      write (iout,*) 'The BUFFER array:'
5024 cd      do i=1,nn
5025 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5026 cd      enddo
5027         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5028           msglen=msglen2
5029             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5030 C Clear the contacts of the atom passed to the neighboring processor
5031         nn=num_cont_hb(iatel_s+1)
5032 cd      do i=1,nn
5033 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5034 cd      enddo
5035             num_cont_hb(iatel_s)=0
5036         endif
5037 cd      write (iout,*) 'Processor ',MyID,MyRank,
5038 cd   & ' is sending correlation contribution to processor',MyID-1,
5039 cd   & ' msglen=',msglen
5040 cd      write (*,*) 'Processor ',MyID,MyRank,
5041 cd   & ' is sending correlation contribution to processor',MyID-1,
5042 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5043         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5044 cd      write (iout,*) 'Processor ',MyID,
5045 cd   & ' has sent correlation contribution to processor',MyID-1,
5046 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5047 cd      write (*,*) 'Processor ',MyID,
5048 cd   & ' has sent correlation contribution to processor',MyID-1,
5049 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5050         msglen=msglen1
5051       endif ! (MyRank.gt.0)
5052       if (ldone) goto 30
5053       ldone=.true.
5054    20 continue
5055 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5056       if (MyRank.lt.fgProcs-1) then
5057 C Receive correlation contributions from the next processor
5058         msglen=msglen1
5059         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5060 cd      write (iout,*) 'Processor',MyID,
5061 cd   & ' is receiving correlation contribution from processor',MyID+1,
5062 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5063 cd      write (*,*) 'Processor',MyID,
5064 cd   & ' is receiving correlation contribution from processor',MyID+1,
5065 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5066         nbytes=-1
5067         do while (nbytes.le.0)
5068           call mp_probe(MyID+1,CorrelType,nbytes)
5069         enddo
5070 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5071         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5072 cd      write (iout,*) 'Processor',MyID,
5073 cd   & ' has received correlation contribution from processor',MyID+1,
5074 cd   & ' msglen=',msglen,' nbytes=',nbytes
5075 cd      write (iout,*) 'The received BUFFER array:'
5076 cd      do i=1,max_cont
5077 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5078 cd      enddo
5079         if (msglen.eq.msglen1) then
5080           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5081         else if (msglen.eq.msglen2)  then
5082           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5083           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5084         else
5085           write (iout,*)
5086      & 'ERROR!!!! message length changed while processing correlations.'
5087           write (*,*)
5088      & 'ERROR!!!! message length changed while processing correlations.'
5089           call mp_stopall(Error)
5090         endif ! msglen.eq.msglen1
5091       endif ! MyRank.lt.fgProcs-1
5092       if (ldone) goto 30
5093       ldone=.true.
5094       goto 10
5095    30 continue
5096 #endif
5097       if (lprn) then
5098         write (iout,'(a)') 'Contact function values:'
5099         do i=nnt,nct-2
5100           write (iout,'(2i3,50(1x,i2,f5.2))')
5101      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5102      &    j=1,num_cont_hb(i))
5103         enddo
5104       endif
5105       ecorr=0.0D0
5106 C Remove the loop below after debugging !!!
5107       do i=nnt,nct
5108         do j=1,3
5109           gradcorr(j,i)=0.0D0
5110           gradxorr(j,i)=0.0D0
5111         enddo
5112       enddo
5113 C Calculate the local-electrostatic correlation terms
5114       do i=iatel_s,iatel_e+1
5115         i1=i+1
5116         num_conti=num_cont_hb(i)
5117         num_conti1=num_cont_hb(i+1)
5118         do jj=1,num_conti
5119           j=jcont_hb(jj,i)
5120           do kk=1,num_conti1
5121             j1=jcont_hb(kk,i1)
5122 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5123 c     &         ' jj=',jj,' kk=',kk
5124             if (j1.eq.j+1 .or. j1.eq.j-1) then
5125 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5126 C The system gains extra energy.
5127               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5128               n_corr=n_corr+1
5129             else if (j1.eq.j) then
5130 C Contacts I-J and I-(J+1) occur simultaneously.
5131 C The system loses extra energy.
5132 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5133             endif
5134           enddo ! kk
5135           do kk=1,num_conti
5136             j1=jcont_hb(kk,i)
5137 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5138 c    &         ' jj=',jj,' kk=',kk
5139             if (j1.eq.j+1) then
5140 C Contacts I-J and (I+1)-J occur simultaneously.
5141 C The system loses extra energy.
5142 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5143             endif ! j1==j+1
5144           enddo ! kk
5145         enddo ! jj
5146       enddo ! i
5147       return
5148       end
5149 c------------------------------------------------------------------------------
5150       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5151      &  n_corr1)
5152 C This subroutine calculates multi-body contributions to hydrogen-bonding
5153       implicit real*8 (a-h,o-z)
5154       include 'DIMENSIONS'
5155       include 'DIMENSIONS.ZSCOPT'
5156       include 'COMMON.IOUNITS'
5157 #ifdef MPL
5158       include 'COMMON.INFO'
5159 #endif
5160       include 'COMMON.FFIELD'
5161       include 'COMMON.DERIV'
5162       include 'COMMON.INTERACT'
5163       include 'COMMON.CONTACTS'
5164 #ifdef MPL
5165       parameter (max_cont=maxconts)
5166       parameter (max_dim=2*(8*3+2))
5167       parameter (msglen1=max_cont*max_dim*4)
5168       parameter (msglen2=2*msglen1)
5169       integer source,CorrelType,CorrelID,Error
5170       double precision buffer(max_cont,max_dim)
5171 #endif
5172       double precision gx(3),gx1(3)
5173       logical lprn,ldone
5174
5175 C Set lprn=.true. for debugging
5176       lprn=.false.
5177       eturn6=0.0d0
5178 #ifdef MPL
5179       n_corr=0
5180       n_corr1=0
5181       if (fgProcs.le.1) goto 30
5182       if (lprn) then
5183         write (iout,'(a)') 'Contact function values:'
5184         do i=nnt,nct-2
5185           write (iout,'(2i3,50(1x,i2,f5.2))')
5186      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5187      &    j=1,num_cont_hb(i))
5188         enddo
5189       endif
5190 C Caution! Following code assumes that electrostatic interactions concerning
5191 C a given atom are split among at most two processors!
5192       CorrelType=477
5193       CorrelID=MyID+1
5194       ldone=.false.
5195       do i=1,max_cont
5196         do j=1,max_dim
5197           buffer(i,j)=0.0D0
5198         enddo
5199       enddo
5200       mm=mod(MyRank,2)
5201 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5202       if (mm) 20,20,10
5203    10 continue
5204 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5205       if (MyRank.gt.0) then
5206 C Send correlation contributions to the preceding processor
5207         msglen=msglen1
5208         nn=num_cont_hb(iatel_s)
5209         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5210 cd      write (iout,*) 'The BUFFER array:'
5211 cd      do i=1,nn
5212 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5213 cd      enddo
5214         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5215           msglen=msglen2
5216             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5217 C Clear the contacts of the atom passed to the neighboring processor
5218         nn=num_cont_hb(iatel_s+1)
5219 cd      do i=1,nn
5220 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5221 cd      enddo
5222             num_cont_hb(iatel_s)=0
5223         endif
5224 cd      write (iout,*) 'Processor ',MyID,MyRank,
5225 cd   & ' is sending correlation contribution to processor',MyID-1,
5226 cd   & ' msglen=',msglen
5227 cd      write (*,*) 'Processor ',MyID,MyRank,
5228 cd   & ' is sending correlation contribution to processor',MyID-1,
5229 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5230         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5231 cd      write (iout,*) 'Processor ',MyID,
5232 cd   & ' has sent correlation contribution to processor',MyID-1,
5233 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5234 cd      write (*,*) 'Processor ',MyID,
5235 cd   & ' has sent correlation contribution to processor',MyID-1,
5236 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5237         msglen=msglen1
5238       endif ! (MyRank.gt.0)
5239       if (ldone) goto 30
5240       ldone=.true.
5241    20 continue
5242 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5243       if (MyRank.lt.fgProcs-1) then
5244 C Receive correlation contributions from the next processor
5245         msglen=msglen1
5246         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5247 cd      write (iout,*) 'Processor',MyID,
5248 cd   & ' is receiving correlation contribution from processor',MyID+1,
5249 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5250 cd      write (*,*) 'Processor',MyID,
5251 cd   & ' is receiving correlation contribution from processor',MyID+1,
5252 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5253         nbytes=-1
5254         do while (nbytes.le.0)
5255           call mp_probe(MyID+1,CorrelType,nbytes)
5256         enddo
5257 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5258         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5259 cd      write (iout,*) 'Processor',MyID,
5260 cd   & ' has received correlation contribution from processor',MyID+1,
5261 cd   & ' msglen=',msglen,' nbytes=',nbytes
5262 cd      write (iout,*) 'The received BUFFER array:'
5263 cd      do i=1,max_cont
5264 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5265 cd      enddo
5266         if (msglen.eq.msglen1) then
5267           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5268         else if (msglen.eq.msglen2)  then
5269           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5270           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5271         else
5272           write (iout,*)
5273      & 'ERROR!!!! message length changed while processing correlations.'
5274           write (*,*)
5275      & 'ERROR!!!! message length changed while processing correlations.'
5276           call mp_stopall(Error)
5277         endif ! msglen.eq.msglen1
5278       endif ! MyRank.lt.fgProcs-1
5279       if (ldone) goto 30
5280       ldone=.true.
5281       goto 10
5282    30 continue
5283 #endif
5284       if (lprn) then
5285         write (iout,'(a)') 'Contact function values:'
5286         do i=nnt,nct-2
5287           write (iout,'(2i3,50(1x,i2,f5.2))')
5288      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5289      &    j=1,num_cont_hb(i))
5290         enddo
5291       endif
5292       ecorr=0.0D0
5293       ecorr5=0.0d0
5294       ecorr6=0.0d0
5295 C Remove the loop below after debugging !!!
5296       do i=nnt,nct
5297         do j=1,3
5298           gradcorr(j,i)=0.0D0
5299           gradxorr(j,i)=0.0D0
5300         enddo
5301       enddo
5302 C Calculate the dipole-dipole interaction energies
5303       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5304       do i=iatel_s,iatel_e+1
5305         num_conti=num_cont_hb(i)
5306         do jj=1,num_conti
5307           j=jcont_hb(jj,i)
5308           call dipole(i,j,jj)
5309         enddo
5310       enddo
5311       endif
5312 C Calculate the local-electrostatic correlation terms
5313       do i=iatel_s,iatel_e+1
5314         i1=i+1
5315         num_conti=num_cont_hb(i)
5316         num_conti1=num_cont_hb(i+1)
5317         do jj=1,num_conti
5318           j=jcont_hb(jj,i)
5319           do kk=1,num_conti1
5320             j1=jcont_hb(kk,i1)
5321 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5322 c     &         ' jj=',jj,' kk=',kk
5323             if (j1.eq.j+1 .or. j1.eq.j-1) then
5324 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5325 C The system gains extra energy.
5326               n_corr=n_corr+1
5327               sqd1=dsqrt(d_cont(jj,i))
5328               sqd2=dsqrt(d_cont(kk,i1))
5329               sred_geom = sqd1*sqd2
5330               IF (sred_geom.lt.cutoff_corr) THEN
5331                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5332      &            ekont,fprimcont)
5333 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5334 c     &         ' jj=',jj,' kk=',kk
5335                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5336                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5337                 do l=1,3
5338                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5339                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5340                 enddo
5341                 n_corr1=n_corr1+1
5342 cd               write (iout,*) 'sred_geom=',sred_geom,
5343 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5344                 call calc_eello(i,j,i+1,j1,jj,kk)
5345                 if (wcorr4.gt.0.0d0)
5346      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5347                 if (wcorr5.gt.0.0d0)
5348      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5349 c                print *,"wcorr5",ecorr5
5350 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5351 cd                write(2,*)'ijkl',i,j,i+1,j1
5352                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5353      &               .or. wturn6.eq.0.0d0))then
5354 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5355                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5356 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5357 cd     &            'ecorr6=',ecorr6
5358 cd                write (iout,'(4e15.5)') sred_geom,
5359 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5360 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5361 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5362                 else if (wturn6.gt.0.0d0
5363      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5364 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5365                   eturn6=eturn6+eello_turn6(i,jj,kk)
5366 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5367                 endif
5368               ENDIF
5369 1111          continue
5370             else if (j1.eq.j) then
5371 C Contacts I-J and I-(J+1) occur simultaneously.
5372 C The system loses extra energy.
5373 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5374             endif
5375           enddo ! kk
5376           do kk=1,num_conti
5377             j1=jcont_hb(kk,i)
5378 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5379 c    &         ' jj=',jj,' kk=',kk
5380             if (j1.eq.j+1) then
5381 C Contacts I-J and (I+1)-J occur simultaneously.
5382 C The system loses extra energy.
5383 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5384             endif ! j1==j+1
5385           enddo ! kk
5386         enddo ! jj
5387       enddo ! i
5388       return
5389       end
5390 c------------------------------------------------------------------------------
5391       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5392       implicit real*8 (a-h,o-z)
5393       include 'DIMENSIONS'
5394       include 'COMMON.IOUNITS'
5395       include 'COMMON.DERIV'
5396       include 'COMMON.INTERACT'
5397       include 'COMMON.CONTACTS'
5398       double precision gx(3),gx1(3)
5399       logical lprn
5400       lprn=.false.
5401       eij=facont_hb(jj,i)
5402       ekl=facont_hb(kk,k)
5403       ees0pij=ees0p(jj,i)
5404       ees0pkl=ees0p(kk,k)
5405       ees0mij=ees0m(jj,i)
5406       ees0mkl=ees0m(kk,k)
5407       ekont=eij*ekl
5408       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5409 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5410 C Following 4 lines for diagnostics.
5411 cd    ees0pkl=0.0D0
5412 cd    ees0pij=1.0D0
5413 cd    ees0mkl=0.0D0
5414 cd    ees0mij=1.0D0
5415 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5416 c    &   ' and',k,l
5417 c     write (iout,*)'Contacts have occurred for peptide groups',
5418 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5419 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5420 C Calculate the multi-body contribution to energy.
5421       ecorr=ecorr+ekont*ees
5422       if (calc_grad) then
5423 C Calculate multi-body contributions to the gradient.
5424       do ll=1,3
5425         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5426         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5427      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5428      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5429         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5430      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5431      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5432         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5433         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5434      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5435      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5436         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5437      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5438      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5439       enddo
5440       do m=i+1,j-1
5441         do ll=1,3
5442           gradcorr(ll,m)=gradcorr(ll,m)+
5443      &     ees*ekl*gacont_hbr(ll,jj,i)-
5444      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5445      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5446         enddo
5447       enddo
5448       do m=k+1,l-1
5449         do ll=1,3
5450           gradcorr(ll,m)=gradcorr(ll,m)+
5451      &     ees*eij*gacont_hbr(ll,kk,k)-
5452      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5453      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5454         enddo
5455       enddo
5456       endif
5457       ehbcorr=ekont*ees
5458       return
5459       end
5460 C---------------------------------------------------------------------------
5461       subroutine dipole(i,j,jj)
5462       implicit real*8 (a-h,o-z)
5463       include 'DIMENSIONS'
5464       include 'DIMENSIONS.ZSCOPT'
5465       include 'COMMON.IOUNITS'
5466       include 'COMMON.CHAIN'
5467       include 'COMMON.FFIELD'
5468       include 'COMMON.DERIV'
5469       include 'COMMON.INTERACT'
5470       include 'COMMON.CONTACTS'
5471       include 'COMMON.TORSION'
5472       include 'COMMON.VAR'
5473       include 'COMMON.GEO'
5474       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5475      &  auxmat(2,2)
5476       iti1 = itortyp(itype(i+1))
5477       if (j.lt.nres-1) then
5478         if (itype(j).le.ntyp) then
5479           itj1 = itortyp(itype(j+1))
5480         else
5481           itj=ntortyp+1
5482         endif
5483       else
5484         itj1=ntortyp+1
5485       endif
5486       do iii=1,2
5487         dipi(iii,1)=Ub2(iii,i)
5488         dipderi(iii)=Ub2der(iii,i)
5489         dipi(iii,2)=b1(iii,iti1)
5490         dipj(iii,1)=Ub2(iii,j)
5491         dipderj(iii)=Ub2der(iii,j)
5492         dipj(iii,2)=b1(iii,itj1)
5493       enddo
5494       kkk=0
5495       do iii=1,2
5496         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5497         do jjj=1,2
5498           kkk=kkk+1
5499           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5500         enddo
5501       enddo
5502       if (.not.calc_grad) return
5503       do kkk=1,5
5504         do lll=1,3
5505           mmm=0
5506           do iii=1,2
5507             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5508      &        auxvec(1))
5509             do jjj=1,2
5510               mmm=mmm+1
5511               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5512             enddo
5513           enddo
5514         enddo
5515       enddo
5516       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5517       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5518       do iii=1,2
5519         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5520       enddo
5521       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5522       do iii=1,2
5523         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5524       enddo
5525       return
5526       end
5527 C---------------------------------------------------------------------------
5528       subroutine calc_eello(i,j,k,l,jj,kk)
5529 C
5530 C This subroutine computes matrices and vectors needed to calculate
5531 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5532 C
5533       implicit real*8 (a-h,o-z)
5534       include 'DIMENSIONS'
5535       include 'DIMENSIONS.ZSCOPT'
5536       include 'COMMON.IOUNITS'
5537       include 'COMMON.CHAIN'
5538       include 'COMMON.DERIV'
5539       include 'COMMON.INTERACT'
5540       include 'COMMON.CONTACTS'
5541       include 'COMMON.TORSION'
5542       include 'COMMON.VAR'
5543       include 'COMMON.GEO'
5544       include 'COMMON.FFIELD'
5545       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5546      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5547       logical lprn
5548       common /kutas/ lprn
5549 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5550 cd     & ' jj=',jj,' kk=',kk
5551 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5552       do iii=1,2
5553         do jjj=1,2
5554           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5555           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5556         enddo
5557       enddo
5558       call transpose2(aa1(1,1),aa1t(1,1))
5559       call transpose2(aa2(1,1),aa2t(1,1))
5560       do kkk=1,5
5561         do lll=1,3
5562           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5563      &      aa1tder(1,1,lll,kkk))
5564           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5565      &      aa2tder(1,1,lll,kkk))
5566         enddo
5567       enddo
5568       if (l.eq.j+1) then
5569 C parallel orientation of the two CA-CA-CA frames.
5570         if (i.gt.1 .and. itype(i).le.ntyp) then
5571           iti=itortyp(itype(i))
5572         else
5573           iti=ntortyp+1
5574         endif
5575         itk1=itortyp(itype(k+1))
5576         itj=itortyp(itype(j))
5577         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
5578           itl1=itortyp(itype(l+1))
5579         else
5580           itl1=ntortyp+1
5581         endif
5582 C A1 kernel(j+1) A2T
5583 cd        do iii=1,2
5584 cd          write (iout,'(3f10.5,5x,3f10.5)')
5585 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5586 cd        enddo
5587         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5588      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5589      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5590 C Following matrices are needed only for 6-th order cumulants
5591         IF (wcorr6.gt.0.0d0) THEN
5592         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5593      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5594      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5595         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5596      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5597      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5598      &   ADtEAderx(1,1,1,1,1,1))
5599         lprn=.false.
5600         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5601      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5602      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5603      &   ADtEA1derx(1,1,1,1,1,1))
5604         ENDIF
5605 C End 6-th order cumulants
5606 cd        lprn=.false.
5607 cd        if (lprn) then
5608 cd        write (2,*) 'In calc_eello6'
5609 cd        do iii=1,2
5610 cd          write (2,*) 'iii=',iii
5611 cd          do kkk=1,5
5612 cd            write (2,*) 'kkk=',kkk
5613 cd            do jjj=1,2
5614 cd              write (2,'(3(2f10.5),5x)')
5615 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5616 cd            enddo
5617 cd          enddo
5618 cd        enddo
5619 cd        endif
5620         call transpose2(EUgder(1,1,k),auxmat(1,1))
5621         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5622         call transpose2(EUg(1,1,k),auxmat(1,1))
5623         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5624         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5625         do iii=1,2
5626           do kkk=1,5
5627             do lll=1,3
5628               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5629      &          EAEAderx(1,1,lll,kkk,iii,1))
5630             enddo
5631           enddo
5632         enddo
5633 C A1T kernel(i+1) A2
5634         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5635      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5636      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5637 C Following matrices are needed only for 6-th order cumulants
5638         IF (wcorr6.gt.0.0d0) THEN
5639         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5640      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5641      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5642         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5643      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
5644      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5645      &   ADtEAderx(1,1,1,1,1,2))
5646         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5647      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5648      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5649      &   ADtEA1derx(1,1,1,1,1,2))
5650         ENDIF
5651 C End 6-th order cumulants
5652         call transpose2(EUgder(1,1,l),auxmat(1,1))
5653         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5654         call transpose2(EUg(1,1,l),auxmat(1,1))
5655         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5656         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5657         do iii=1,2
5658           do kkk=1,5
5659             do lll=1,3
5660               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5661      &          EAEAderx(1,1,lll,kkk,iii,2))
5662             enddo
5663           enddo
5664         enddo
5665 C AEAb1 and AEAb2
5666 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5667 C They are needed only when the fifth- or the sixth-order cumulants are
5668 C indluded.
5669         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5670         call transpose2(AEA(1,1,1),auxmat(1,1))
5671         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5672         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5673         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5674         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5675         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5676         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5677         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5678         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5679         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5680         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5681         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5682         call transpose2(AEA(1,1,2),auxmat(1,1))
5683         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5684         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5685         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5686         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5687         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5688         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5689         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5690         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5691         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5692         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5693         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5694 C Calculate the Cartesian derivatives of the vectors.
5695         do iii=1,2
5696           do kkk=1,5
5697             do lll=1,3
5698               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5699               call matvec2(auxmat(1,1),b1(1,iti),
5700      &          AEAb1derx(1,lll,kkk,iii,1,1))
5701               call matvec2(auxmat(1,1),Ub2(1,i),
5702      &          AEAb2derx(1,lll,kkk,iii,1,1))
5703               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5704      &          AEAb1derx(1,lll,kkk,iii,2,1))
5705               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5706      &          AEAb2derx(1,lll,kkk,iii,2,1))
5707               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5708               call matvec2(auxmat(1,1),b1(1,itj),
5709      &          AEAb1derx(1,lll,kkk,iii,1,2))
5710               call matvec2(auxmat(1,1),Ub2(1,j),
5711      &          AEAb2derx(1,lll,kkk,iii,1,2))
5712               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
5713      &          AEAb1derx(1,lll,kkk,iii,2,2))
5714               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
5715      &          AEAb2derx(1,lll,kkk,iii,2,2))
5716             enddo
5717           enddo
5718         enddo
5719         ENDIF
5720 C End vectors
5721       else
5722 C Antiparallel orientation of the two CA-CA-CA frames.
5723         if (i.gt.1 .and. itype(i).le.ntyp) then
5724           iti=itortyp(itype(i))
5725         else
5726           iti=ntortyp+1
5727         endif
5728         itk1=itortyp(itype(k+1))
5729         itl=itortyp(itype(l))
5730         itj=itortyp(itype(j))
5731         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
5732           itj1=itortyp(itype(j+1))
5733         else
5734           itj1=ntortyp+1
5735         endif
5736 C A2 kernel(j-1)T A1T
5737         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5738      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
5739      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5740 C Following matrices are needed only for 6-th order cumulants
5741         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5742      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5743         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5744      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
5745      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5746         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5747      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
5748      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5749      &   ADtEAderx(1,1,1,1,1,1))
5750         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5751      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
5752      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5753      &   ADtEA1derx(1,1,1,1,1,1))
5754         ENDIF
5755 C End 6-th order cumulants
5756         call transpose2(EUgder(1,1,k),auxmat(1,1))
5757         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5758         call transpose2(EUg(1,1,k),auxmat(1,1))
5759         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5760         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5761         do iii=1,2
5762           do kkk=1,5
5763             do lll=1,3
5764               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5765      &          EAEAderx(1,1,lll,kkk,iii,1))
5766             enddo
5767           enddo
5768         enddo
5769 C A2T kernel(i+1)T A1
5770         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5771      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
5772      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5773 C Following matrices are needed only for 6-th order cumulants
5774         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5775      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5776         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5777      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
5778      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5779         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5780      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
5781      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5782      &   ADtEAderx(1,1,1,1,1,2))
5783         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5784      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
5785      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5786      &   ADtEA1derx(1,1,1,1,1,2))
5787         ENDIF
5788 C End 6-th order cumulants
5789         call transpose2(EUgder(1,1,j),auxmat(1,1))
5790         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
5791         call transpose2(EUg(1,1,j),auxmat(1,1))
5792         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5793         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5794         do iii=1,2
5795           do kkk=1,5
5796             do lll=1,3
5797               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5798      &          EAEAderx(1,1,lll,kkk,iii,2))
5799             enddo
5800           enddo
5801         enddo
5802 C AEAb1 and AEAb2
5803 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5804 C They are needed only when the fifth- or the sixth-order cumulants are
5805 C indluded.
5806         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
5807      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
5808         call transpose2(AEA(1,1,1),auxmat(1,1))
5809         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5810         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5811         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5812         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5813         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5814         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5815         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5816         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5817         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5818         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5819         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5820         call transpose2(AEA(1,1,2),auxmat(1,1))
5821         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
5822         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
5823         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
5824         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5825         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
5826         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
5827         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
5828         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
5829         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
5830         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
5831         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
5832 C Calculate the Cartesian derivatives of the vectors.
5833         do iii=1,2
5834           do kkk=1,5
5835             do lll=1,3
5836               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5837               call matvec2(auxmat(1,1),b1(1,iti),
5838      &          AEAb1derx(1,lll,kkk,iii,1,1))
5839               call matvec2(auxmat(1,1),Ub2(1,i),
5840      &          AEAb2derx(1,lll,kkk,iii,1,1))
5841               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5842      &          AEAb1derx(1,lll,kkk,iii,2,1))
5843               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5844      &          AEAb2derx(1,lll,kkk,iii,2,1))
5845               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5846               call matvec2(auxmat(1,1),b1(1,itl),
5847      &          AEAb1derx(1,lll,kkk,iii,1,2))
5848               call matvec2(auxmat(1,1),Ub2(1,l),
5849      &          AEAb2derx(1,lll,kkk,iii,1,2))
5850               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
5851      &          AEAb1derx(1,lll,kkk,iii,2,2))
5852               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
5853      &          AEAb2derx(1,lll,kkk,iii,2,2))
5854             enddo
5855           enddo
5856         enddo
5857         ENDIF
5858 C End vectors
5859       endif
5860       return
5861       end
5862 C---------------------------------------------------------------------------
5863       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
5864      &  KK,KKderg,AKA,AKAderg,AKAderx)
5865       implicit none
5866       integer nderg
5867       logical transp
5868       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
5869      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
5870      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
5871       integer iii,kkk,lll
5872       integer jjj,mmm
5873       logical lprn
5874       common /kutas/ lprn
5875       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
5876       do iii=1,nderg
5877         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
5878      &    AKAderg(1,1,iii))
5879       enddo
5880 cd      if (lprn) write (2,*) 'In kernel'
5881       do kkk=1,5
5882 cd        if (lprn) write (2,*) 'kkk=',kkk
5883         do lll=1,3
5884           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
5885      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
5886 cd          if (lprn) then
5887 cd            write (2,*) 'lll=',lll
5888 cd            write (2,*) 'iii=1'
5889 cd            do jjj=1,2
5890 cd              write (2,'(3(2f10.5),5x)')
5891 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
5892 cd            enddo
5893 cd          endif
5894           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
5895      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
5896 cd          if (lprn) then
5897 cd            write (2,*) 'lll=',lll
5898 cd            write (2,*) 'iii=2'
5899 cd            do jjj=1,2
5900 cd              write (2,'(3(2f10.5),5x)')
5901 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
5902 cd            enddo
5903 cd          endif
5904         enddo
5905       enddo
5906       return
5907       end
5908 C---------------------------------------------------------------------------
5909       double precision function eello4(i,j,k,l,jj,kk)
5910       implicit real*8 (a-h,o-z)
5911       include 'DIMENSIONS'
5912       include 'DIMENSIONS.ZSCOPT'
5913       include 'COMMON.IOUNITS'
5914       include 'COMMON.CHAIN'
5915       include 'COMMON.DERIV'
5916       include 'COMMON.INTERACT'
5917       include 'COMMON.CONTACTS'
5918       include 'COMMON.TORSION'
5919       include 'COMMON.VAR'
5920       include 'COMMON.GEO'
5921       double precision pizda(2,2),ggg1(3),ggg2(3)
5922 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
5923 cd        eello4=0.0d0
5924 cd        return
5925 cd      endif
5926 cd      print *,'eello4:',i,j,k,l,jj,kk
5927 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
5928 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
5929 cold      eij=facont_hb(jj,i)
5930 cold      ekl=facont_hb(kk,k)
5931 cold      ekont=eij*ekl
5932       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
5933       if (calc_grad) then
5934 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
5935       gcorr_loc(k-1)=gcorr_loc(k-1)
5936      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
5937       if (l.eq.j+1) then
5938         gcorr_loc(l-1)=gcorr_loc(l-1)
5939      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5940       else
5941         gcorr_loc(j-1)=gcorr_loc(j-1)
5942      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5943       endif
5944       do iii=1,2
5945         do kkk=1,5
5946           do lll=1,3
5947             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
5948      &                        -EAEAderx(2,2,lll,kkk,iii,1)
5949 cd            derx(lll,kkk,iii)=0.0d0
5950           enddo
5951         enddo
5952       enddo
5953 cd      gcorr_loc(l-1)=0.0d0
5954 cd      gcorr_loc(j-1)=0.0d0
5955 cd      gcorr_loc(k-1)=0.0d0
5956 cd      eel4=1.0d0
5957 cd      write (iout,*)'Contacts have occurred for peptide groups',
5958 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
5959 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
5960       if (j.lt.nres-1) then
5961         j1=j+1
5962         j2=j-1
5963       else
5964         j1=j-1
5965         j2=j-2
5966       endif
5967       if (l.lt.nres-1) then
5968         l1=l+1
5969         l2=l-1
5970       else
5971         l1=l-1
5972         l2=l-2
5973       endif
5974       do ll=1,3
5975 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
5976         ggg1(ll)=eel4*g_contij(ll,1)
5977         ggg2(ll)=eel4*g_contij(ll,2)
5978         ghalf=0.5d0*ggg1(ll)
5979 cd        ghalf=0.0d0
5980         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
5981         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
5982         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
5983         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
5984 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
5985         ghalf=0.5d0*ggg2(ll)
5986 cd        ghalf=0.0d0
5987         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
5988         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
5989         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
5990         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
5991       enddo
5992 cd      goto 1112
5993       do m=i+1,j-1
5994         do ll=1,3
5995 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
5996           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
5997         enddo
5998       enddo
5999       do m=k+1,l-1
6000         do ll=1,3
6001 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6002           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6003         enddo
6004       enddo
6005 1112  continue
6006       do m=i+2,j2
6007         do ll=1,3
6008           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6009         enddo
6010       enddo
6011       do m=k+2,l2
6012         do ll=1,3
6013           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6014         enddo
6015       enddo
6016 cd      do iii=1,nres-3
6017 cd        write (2,*) iii,gcorr_loc(iii)
6018 cd      enddo
6019       endif
6020       eello4=ekont*eel4
6021 cd      write (2,*) 'ekont',ekont
6022 cd      write (iout,*) 'eello4',ekont*eel4
6023       return
6024       end
6025 C---------------------------------------------------------------------------
6026       double precision function eello5(i,j,k,l,jj,kk)
6027       implicit real*8 (a-h,o-z)
6028       include 'DIMENSIONS'
6029       include 'DIMENSIONS.ZSCOPT'
6030       include 'COMMON.IOUNITS'
6031       include 'COMMON.CHAIN'
6032       include 'COMMON.DERIV'
6033       include 'COMMON.INTERACT'
6034       include 'COMMON.CONTACTS'
6035       include 'COMMON.TORSION'
6036       include 'COMMON.VAR'
6037       include 'COMMON.GEO'
6038       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6039       double precision ggg1(3),ggg2(3)
6040 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6041 C                                                                              C
6042 C                            Parallel chains                                   C
6043 C                                                                              C
6044 C          o             o                   o             o                   C
6045 C         /l\           / \             \   / \           / \   /              C
6046 C        /   \         /   \             \ /   \         /   \ /               C
6047 C       j| o |l1       | o |              o| o |         | o |o                C
6048 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6049 C      \i/   \         /   \ /             /   \         /   \                 C
6050 C       o    k1             o                                                  C
6051 C         (I)          (II)                (III)          (IV)                 C
6052 C                                                                              C
6053 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6054 C                                                                              C
6055 C                            Antiparallel chains                               C
6056 C                                                                              C
6057 C          o             o                   o             o                   C
6058 C         /j\           / \             \   / \           / \   /              C
6059 C        /   \         /   \             \ /   \         /   \ /               C
6060 C      j1| o |l        | o |              o| o |         | o |o                C
6061 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6062 C      \i/   \         /   \ /             /   \         /   \                 C
6063 C       o     k1            o                                                  C
6064 C         (I)          (II)                (III)          (IV)                 C
6065 C                                                                              C
6066 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6067 C                                                                              C
6068 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6069 C                                                                              C
6070 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6071 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6072 cd        eello5=0.0d0
6073 cd        return
6074 cd      endif
6075 cd      write (iout,*)
6076 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6077 cd     &   ' and',k,l
6078       itk=itortyp(itype(k))
6079       itl=itortyp(itype(l))
6080       itj=itortyp(itype(j))
6081       eello5_1=0.0d0
6082       eello5_2=0.0d0
6083       eello5_3=0.0d0
6084       eello5_4=0.0d0
6085 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6086 cd     &   eel5_3_num,eel5_4_num)
6087       do iii=1,2
6088         do kkk=1,5
6089           do lll=1,3
6090             derx(lll,kkk,iii)=0.0d0
6091           enddo
6092         enddo
6093       enddo
6094 cd      eij=facont_hb(jj,i)
6095 cd      ekl=facont_hb(kk,k)
6096 cd      ekont=eij*ekl
6097 cd      write (iout,*)'Contacts have occurred for peptide groups',
6098 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6099 cd      goto 1111
6100 C Contribution from the graph I.
6101 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6102 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6103       call transpose2(EUg(1,1,k),auxmat(1,1))
6104       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6105       vv(1)=pizda(1,1)-pizda(2,2)
6106       vv(2)=pizda(1,2)+pizda(2,1)
6107       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6108      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6109       if (calc_grad) then
6110 C Explicit gradient in virtual-dihedral angles.
6111       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6112      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6113      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6114       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6115       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6116       vv(1)=pizda(1,1)-pizda(2,2)
6117       vv(2)=pizda(1,2)+pizda(2,1)
6118       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6119      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6120      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6121       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6122       vv(1)=pizda(1,1)-pizda(2,2)
6123       vv(2)=pizda(1,2)+pizda(2,1)
6124       if (l.eq.j+1) then
6125         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6126      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6127      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6128       else
6129         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6130      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6131      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6132       endif
6133 C Cartesian gradient
6134       do iii=1,2
6135         do kkk=1,5
6136           do lll=1,3
6137             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6138      &        pizda(1,1))
6139             vv(1)=pizda(1,1)-pizda(2,2)
6140             vv(2)=pizda(1,2)+pizda(2,1)
6141             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6142      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6143      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6144           enddo
6145         enddo
6146       enddo
6147 c      goto 1112
6148       endif
6149 c1111  continue
6150 C Contribution from graph II
6151       call transpose2(EE(1,1,itk),auxmat(1,1))
6152       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6153       vv(1)=pizda(1,1)+pizda(2,2)
6154       vv(2)=pizda(2,1)-pizda(1,2)
6155       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6156      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6157       if (calc_grad) then
6158 C Explicit gradient in virtual-dihedral angles.
6159       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6160      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6161       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6162       vv(1)=pizda(1,1)+pizda(2,2)
6163       vv(2)=pizda(2,1)-pizda(1,2)
6164       if (l.eq.j+1) then
6165         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6166      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6167      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6168       else
6169         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6170      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6171      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6172       endif
6173 C Cartesian gradient
6174       do iii=1,2
6175         do kkk=1,5
6176           do lll=1,3
6177             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6178      &        pizda(1,1))
6179             vv(1)=pizda(1,1)+pizda(2,2)
6180             vv(2)=pizda(2,1)-pizda(1,2)
6181             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6182      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6183      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6184           enddo
6185         enddo
6186       enddo
6187 cd      goto 1112
6188       endif
6189 cd1111  continue
6190       if (l.eq.j+1) then
6191 cd        goto 1110
6192 C Parallel orientation
6193 C Contribution from graph III
6194         call transpose2(EUg(1,1,l),auxmat(1,1))
6195         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6196         vv(1)=pizda(1,1)-pizda(2,2)
6197         vv(2)=pizda(1,2)+pizda(2,1)
6198         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6199      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6200         if (calc_grad) then
6201 C Explicit gradient in virtual-dihedral angles.
6202         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6203      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6204      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6205         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6206         vv(1)=pizda(1,1)-pizda(2,2)
6207         vv(2)=pizda(1,2)+pizda(2,1)
6208         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6209      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6210      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6211         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6212         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6213         vv(1)=pizda(1,1)-pizda(2,2)
6214         vv(2)=pizda(1,2)+pizda(2,1)
6215         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6216      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6217      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6218 C Cartesian gradient
6219         do iii=1,2
6220           do kkk=1,5
6221             do lll=1,3
6222               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6223      &          pizda(1,1))
6224               vv(1)=pizda(1,1)-pizda(2,2)
6225               vv(2)=pizda(1,2)+pizda(2,1)
6226               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6227      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6228      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6229             enddo
6230           enddo
6231         enddo
6232 cd        goto 1112
6233         endif
6234 C Contribution from graph IV
6235 cd1110    continue
6236         call transpose2(EE(1,1,itl),auxmat(1,1))
6237         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6238         vv(1)=pizda(1,1)+pizda(2,2)
6239         vv(2)=pizda(2,1)-pizda(1,2)
6240         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6241      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6242         if (calc_grad) then
6243 C Explicit gradient in virtual-dihedral angles.
6244         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6245      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6246         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6247         vv(1)=pizda(1,1)+pizda(2,2)
6248         vv(2)=pizda(2,1)-pizda(1,2)
6249         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6250      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6251      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6252 C Cartesian gradient
6253         do iii=1,2
6254           do kkk=1,5
6255             do lll=1,3
6256               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6257      &          pizda(1,1))
6258               vv(1)=pizda(1,1)+pizda(2,2)
6259               vv(2)=pizda(2,1)-pizda(1,2)
6260               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6261      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6262      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6263             enddo
6264           enddo
6265         enddo
6266         endif
6267       else
6268 C Antiparallel orientation
6269 C Contribution from graph III
6270 c        goto 1110
6271         call transpose2(EUg(1,1,j),auxmat(1,1))
6272         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6273         vv(1)=pizda(1,1)-pizda(2,2)
6274         vv(2)=pizda(1,2)+pizda(2,1)
6275         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6276      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6277         if (calc_grad) then
6278 C Explicit gradient in virtual-dihedral angles.
6279         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6280      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6281      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6282         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6283         vv(1)=pizda(1,1)-pizda(2,2)
6284         vv(2)=pizda(1,2)+pizda(2,1)
6285         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6286      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6287      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6288         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6289         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6290         vv(1)=pizda(1,1)-pizda(2,2)
6291         vv(2)=pizda(1,2)+pizda(2,1)
6292         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6293      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6294      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6295 C Cartesian gradient
6296         do iii=1,2
6297           do kkk=1,5
6298             do lll=1,3
6299               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6300      &          pizda(1,1))
6301               vv(1)=pizda(1,1)-pizda(2,2)
6302               vv(2)=pizda(1,2)+pizda(2,1)
6303               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6304      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6305      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6306             enddo
6307           enddo
6308         enddo
6309 cd        goto 1112
6310         endif
6311 C Contribution from graph IV
6312 1110    continue
6313         call transpose2(EE(1,1,itj),auxmat(1,1))
6314         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6315         vv(1)=pizda(1,1)+pizda(2,2)
6316         vv(2)=pizda(2,1)-pizda(1,2)
6317         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6318      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6319         if (calc_grad) then
6320 C Explicit gradient in virtual-dihedral angles.
6321         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6322      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6323         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6324         vv(1)=pizda(1,1)+pizda(2,2)
6325         vv(2)=pizda(2,1)-pizda(1,2)
6326         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6327      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6328      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6329 C Cartesian gradient
6330         do iii=1,2
6331           do kkk=1,5
6332             do lll=1,3
6333               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6334      &          pizda(1,1))
6335               vv(1)=pizda(1,1)+pizda(2,2)
6336               vv(2)=pizda(2,1)-pizda(1,2)
6337               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6338      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6339      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6340             enddo
6341           enddo
6342         enddo
6343       endif
6344       endif
6345 1112  continue
6346       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6347 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6348 cd        write (2,*) 'ijkl',i,j,k,l
6349 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6350 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6351 cd      endif
6352 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6353 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6354 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6355 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6356       if (calc_grad) then
6357       if (j.lt.nres-1) then
6358         j1=j+1
6359         j2=j-1
6360       else
6361         j1=j-1
6362         j2=j-2
6363       endif
6364       if (l.lt.nres-1) then
6365         l1=l+1
6366         l2=l-1
6367       else
6368         l1=l-1
6369         l2=l-2
6370       endif
6371 cd      eij=1.0d0
6372 cd      ekl=1.0d0
6373 cd      ekont=1.0d0
6374 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6375       do ll=1,3
6376         ggg1(ll)=eel5*g_contij(ll,1)
6377         ggg2(ll)=eel5*g_contij(ll,2)
6378 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6379         ghalf=0.5d0*ggg1(ll)
6380 cd        ghalf=0.0d0
6381         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6382         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6383         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6384         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6385 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6386         ghalf=0.5d0*ggg2(ll)
6387 cd        ghalf=0.0d0
6388         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6389         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6390         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6391         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6392       enddo
6393 cd      goto 1112
6394       do m=i+1,j-1
6395         do ll=1,3
6396 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6397           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6398         enddo
6399       enddo
6400       do m=k+1,l-1
6401         do ll=1,3
6402 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6403           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6404         enddo
6405       enddo
6406 c1112  continue
6407       do m=i+2,j2
6408         do ll=1,3
6409           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6410         enddo
6411       enddo
6412       do m=k+2,l2
6413         do ll=1,3
6414           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6415         enddo
6416       enddo
6417 cd      do iii=1,nres-3
6418 cd        write (2,*) iii,g_corr5_loc(iii)
6419 cd      enddo
6420       endif
6421       eello5=ekont*eel5
6422 cd      write (2,*) 'ekont',ekont
6423 cd      write (iout,*) 'eello5',ekont*eel5
6424       return
6425       end
6426 c--------------------------------------------------------------------------
6427       double precision function eello6(i,j,k,l,jj,kk)
6428       implicit real*8 (a-h,o-z)
6429       include 'DIMENSIONS'
6430       include 'DIMENSIONS.ZSCOPT'
6431       include 'COMMON.IOUNITS'
6432       include 'COMMON.CHAIN'
6433       include 'COMMON.DERIV'
6434       include 'COMMON.INTERACT'
6435       include 'COMMON.CONTACTS'
6436       include 'COMMON.TORSION'
6437       include 'COMMON.VAR'
6438       include 'COMMON.GEO'
6439       include 'COMMON.FFIELD'
6440       double precision ggg1(3),ggg2(3)
6441 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6442 cd        eello6=0.0d0
6443 cd        return
6444 cd      endif
6445 cd      write (iout,*)
6446 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6447 cd     &   ' and',k,l
6448       eello6_1=0.0d0
6449       eello6_2=0.0d0
6450       eello6_3=0.0d0
6451       eello6_4=0.0d0
6452       eello6_5=0.0d0
6453       eello6_6=0.0d0
6454 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6455 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6456       do iii=1,2
6457         do kkk=1,5
6458           do lll=1,3
6459             derx(lll,kkk,iii)=0.0d0
6460           enddo
6461         enddo
6462       enddo
6463 cd      eij=facont_hb(jj,i)
6464 cd      ekl=facont_hb(kk,k)
6465 cd      ekont=eij*ekl
6466 cd      eij=1.0d0
6467 cd      ekl=1.0d0
6468 cd      ekont=1.0d0
6469       if (l.eq.j+1) then
6470         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6471         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6472         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6473         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6474         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6475         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6476       else
6477         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6478         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6479         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6480         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6481         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6482           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6483         else
6484           eello6_5=0.0d0
6485         endif
6486         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6487       endif
6488 C If turn contributions are considered, they will be handled separately.
6489       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6490 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6491 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6492 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6493 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6494 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6495 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6496 cd      goto 1112
6497       if (calc_grad) then
6498       if (j.lt.nres-1) then
6499         j1=j+1
6500         j2=j-1
6501       else
6502         j1=j-1
6503         j2=j-2
6504       endif
6505       if (l.lt.nres-1) then
6506         l1=l+1
6507         l2=l-1
6508       else
6509         l1=l-1
6510         l2=l-2
6511       endif
6512       do ll=1,3
6513         ggg1(ll)=eel6*g_contij(ll,1)
6514         ggg2(ll)=eel6*g_contij(ll,2)
6515 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6516         ghalf=0.5d0*ggg1(ll)
6517 cd        ghalf=0.0d0
6518         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6519         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6520         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6521         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6522         ghalf=0.5d0*ggg2(ll)
6523 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6524 cd        ghalf=0.0d0
6525         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6526         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6527         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6528         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6529       enddo
6530 cd      goto 1112
6531       do m=i+1,j-1
6532         do ll=1,3
6533 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6534           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6535         enddo
6536       enddo
6537       do m=k+1,l-1
6538         do ll=1,3
6539 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6540           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6541         enddo
6542       enddo
6543 1112  continue
6544       do m=i+2,j2
6545         do ll=1,3
6546           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6547         enddo
6548       enddo
6549       do m=k+2,l2
6550         do ll=1,3
6551           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6552         enddo
6553       enddo
6554 cd      do iii=1,nres-3
6555 cd        write (2,*) iii,g_corr6_loc(iii)
6556 cd      enddo
6557       endif
6558       eello6=ekont*eel6
6559 cd      write (2,*) 'ekont',ekont
6560 cd      write (iout,*) 'eello6',ekont*eel6
6561       return
6562       end
6563 c--------------------------------------------------------------------------
6564       double precision function eello6_graph1(i,j,k,l,imat,swap)
6565       implicit real*8 (a-h,o-z)
6566       include 'DIMENSIONS'
6567       include 'DIMENSIONS.ZSCOPT'
6568       include 'COMMON.IOUNITS'
6569       include 'COMMON.CHAIN'
6570       include 'COMMON.DERIV'
6571       include 'COMMON.INTERACT'
6572       include 'COMMON.CONTACTS'
6573       include 'COMMON.TORSION'
6574       include 'COMMON.VAR'
6575       include 'COMMON.GEO'
6576       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6577       logical swap
6578       logical lprn
6579       common /kutas/ lprn
6580 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6581 C                                                                              C
6582 C      Parallel       Antiparallel                                             C
6583 C                                                                              C
6584 C          o             o                                                     C
6585 C         /l\           /j\                                                    C
6586 C        /   \         /   \                                                   C
6587 C       /| o |         | o |\                                                  C
6588 C     \ j|/k\|  /   \  |/k\|l /                                                C
6589 C      \ /   \ /     \ /   \ /                                                 C
6590 C       o     o       o     o                                                  C
6591 C       i             i                                                        C
6592 C                                                                              C
6593 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6594       itk=itortyp(itype(k))
6595       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6596       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6597       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6598       call transpose2(EUgC(1,1,k),auxmat(1,1))
6599       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6600       vv1(1)=pizda1(1,1)-pizda1(2,2)
6601       vv1(2)=pizda1(1,2)+pizda1(2,1)
6602       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6603       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6604       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6605       s5=scalar2(vv(1),Dtobr2(1,i))
6606 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6607       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6608       if (.not. calc_grad) return
6609       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6610      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6611      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6612      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6613      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6614      & +scalar2(vv(1),Dtobr2der(1,i)))
6615       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6616       vv1(1)=pizda1(1,1)-pizda1(2,2)
6617       vv1(2)=pizda1(1,2)+pizda1(2,1)
6618       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6619       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6620       if (l.eq.j+1) then
6621         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6622      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6623      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6624      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6625      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6626       else
6627         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6628      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6629      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6630      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6631      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6632       endif
6633       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6634       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6635       vv1(1)=pizda1(1,1)-pizda1(2,2)
6636       vv1(2)=pizda1(1,2)+pizda1(2,1)
6637       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6638      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6639      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6640      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6641       do iii=1,2
6642         if (swap) then
6643           ind=3-iii
6644         else
6645           ind=iii
6646         endif
6647         do kkk=1,5
6648           do lll=1,3
6649             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6650             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6651             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6652             call transpose2(EUgC(1,1,k),auxmat(1,1))
6653             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6654      &        pizda1(1,1))
6655             vv1(1)=pizda1(1,1)-pizda1(2,2)
6656             vv1(2)=pizda1(1,2)+pizda1(2,1)
6657             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6658             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6659      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6660             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6661      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6662             s5=scalar2(vv(1),Dtobr2(1,i))
6663             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6664           enddo
6665         enddo
6666       enddo
6667       return
6668       end
6669 c----------------------------------------------------------------------------
6670       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6671       implicit real*8 (a-h,o-z)
6672       include 'DIMENSIONS'
6673       include 'DIMENSIONS.ZSCOPT'
6674       include 'COMMON.IOUNITS'
6675       include 'COMMON.CHAIN'
6676       include 'COMMON.DERIV'
6677       include 'COMMON.INTERACT'
6678       include 'COMMON.CONTACTS'
6679       include 'COMMON.TORSION'
6680       include 'COMMON.VAR'
6681       include 'COMMON.GEO'
6682       logical swap
6683       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6684      & auxvec1(2),auxvec2(2),auxmat1(2,2)
6685       logical lprn
6686       common /kutas/ lprn
6687 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6688 C                                                                              C
6689 C      Parallel       Antiparallel                                             C
6690 C                                                                              C
6691 C          o             o                                                     C
6692 C     \   /l\           /j\   /                                                C
6693 C      \ /   \         /   \ /                                                 C
6694 C       o| o |         | o |o                                                  C
6695 C     \ j|/k\|      \  |/k\|l                                                  C
6696 C      \ /   \       \ /   \                                                   C
6697 C       o             o                                                        C
6698 C       i             i                                                        C
6699 C                                                                              C
6700 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6701 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6702 C AL 7/4/01 s1 would occur in the sixth-order moment,
6703 C           but not in a cluster cumulant
6704 #ifdef MOMENT
6705       s1=dip(1,jj,i)*dip(1,kk,k)
6706 #endif
6707       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
6708       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6709       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
6710       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
6711       call transpose2(EUg(1,1,k),auxmat(1,1))
6712       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
6713       vv(1)=pizda(1,1)-pizda(2,2)
6714       vv(2)=pizda(1,2)+pizda(2,1)
6715       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6716 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6717 #ifdef MOMENT
6718       eello6_graph2=-(s1+s2+s3+s4)
6719 #else
6720       eello6_graph2=-(s2+s3+s4)
6721 #endif
6722 c      eello6_graph2=-s3
6723       if (.not. calc_grad) return
6724 C Derivatives in gamma(i-1)
6725       if (i.gt.1) then
6726 #ifdef MOMENT
6727         s1=dipderg(1,jj,i)*dip(1,kk,k)
6728 #endif
6729         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6730         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
6731         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6732         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6733 #ifdef MOMENT
6734         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6735 #else
6736         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6737 #endif
6738 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
6739       endif
6740 C Derivatives in gamma(k-1)
6741 #ifdef MOMENT
6742       s1=dip(1,jj,i)*dipderg(1,kk,k)
6743 #endif
6744       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
6745       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6746       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
6747       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6748       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6749       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
6750       vv(1)=pizda(1,1)-pizda(2,2)
6751       vv(2)=pizda(1,2)+pizda(2,1)
6752       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6753 #ifdef MOMENT
6754       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6755 #else
6756       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6757 #endif
6758 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
6759 C Derivatives in gamma(j-1) or gamma(l-1)
6760       if (j.gt.1) then
6761 #ifdef MOMENT
6762         s1=dipderg(3,jj,i)*dip(1,kk,k)
6763 #endif
6764         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
6765         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6766         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
6767         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
6768         vv(1)=pizda(1,1)-pizda(2,2)
6769         vv(2)=pizda(1,2)+pizda(2,1)
6770         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6771 #ifdef MOMENT
6772         if (swap) then
6773           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6774         else
6775           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6776         endif
6777 #endif
6778         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
6779 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
6780       endif
6781 C Derivatives in gamma(l-1) or gamma(j-1)
6782       if (l.gt.1) then
6783 #ifdef MOMENT
6784         s1=dip(1,jj,i)*dipderg(3,kk,k)
6785 #endif
6786         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
6787         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6788         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
6789         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6790         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
6791         vv(1)=pizda(1,1)-pizda(2,2)
6792         vv(2)=pizda(1,2)+pizda(2,1)
6793         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6794 #ifdef MOMENT
6795         if (swap) then
6796           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6797         else
6798           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6799         endif
6800 #endif
6801         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
6802 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
6803       endif
6804 C Cartesian derivatives.
6805       if (lprn) then
6806         write (2,*) 'In eello6_graph2'
6807         do iii=1,2
6808           write (2,*) 'iii=',iii
6809           do kkk=1,5
6810             write (2,*) 'kkk=',kkk
6811             do jjj=1,2
6812               write (2,'(3(2f10.5),5x)')
6813      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6814             enddo
6815           enddo
6816         enddo
6817       endif
6818       do iii=1,2
6819         do kkk=1,5
6820           do lll=1,3
6821 #ifdef MOMENT
6822             if (iii.eq.1) then
6823               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
6824             else
6825               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
6826             endif
6827 #endif
6828             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
6829      &        auxvec(1))
6830             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6831             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
6832      &        auxvec(1))
6833             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
6834             call transpose2(EUg(1,1,k),auxmat(1,1))
6835             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
6836      &        pizda(1,1))
6837             vv(1)=pizda(1,1)-pizda(2,2)
6838             vv(2)=pizda(1,2)+pizda(2,1)
6839             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6840 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
6841 #ifdef MOMENT
6842             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6843 #else
6844             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6845 #endif
6846             if (swap) then
6847               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6848             else
6849               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6850             endif
6851           enddo
6852         enddo
6853       enddo
6854       return
6855       end
6856 c----------------------------------------------------------------------------
6857       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
6858       implicit real*8 (a-h,o-z)
6859       include 'DIMENSIONS'
6860       include 'DIMENSIONS.ZSCOPT'
6861       include 'COMMON.IOUNITS'
6862       include 'COMMON.CHAIN'
6863       include 'COMMON.DERIV'
6864       include 'COMMON.INTERACT'
6865       include 'COMMON.CONTACTS'
6866       include 'COMMON.TORSION'
6867       include 'COMMON.VAR'
6868       include 'COMMON.GEO'
6869       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
6870       logical swap
6871 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6872 C                                                                              C
6873 C      Parallel       Antiparallel                                             C
6874 C                                                                              C
6875 C          o             o                                                     C
6876 C         /l\   /   \   /j\                                                    C
6877 C        /   \ /     \ /   \                                                   C
6878 C       /| o |o       o| o |\                                                  C
6879 C       j|/k\|  /      |/k\|l /                                                C
6880 C        /   \ /       /   \ /                                                 C
6881 C       /     o       /     o                                                  C
6882 C       i             i                                                        C
6883 C                                                                              C
6884 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6885 C
6886 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6887 C           energy moment and not to the cluster cumulant.
6888       iti=itortyp(itype(i))
6889       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6890         itj1=itortyp(itype(j+1))
6891       else
6892         itj1=ntortyp+1
6893       endif
6894       itk=itortyp(itype(k))
6895       itk1=itortyp(itype(k+1))
6896       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6897         itl1=itortyp(itype(l+1))
6898       else
6899         itl1=ntortyp+1
6900       endif
6901 #ifdef MOMENT
6902       s1=dip(4,jj,i)*dip(4,kk,k)
6903 #endif
6904       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
6905       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6906       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
6907       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6908       call transpose2(EE(1,1,itk),auxmat(1,1))
6909       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
6910       vv(1)=pizda(1,1)+pizda(2,2)
6911       vv(2)=pizda(2,1)-pizda(1,2)
6912       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6913 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6914 #ifdef MOMENT
6915       eello6_graph3=-(s1+s2+s3+s4)
6916 #else
6917       eello6_graph3=-(s2+s3+s4)
6918 #endif
6919 c      eello6_graph3=-s4
6920       if (.not. calc_grad) return
6921 C Derivatives in gamma(k-1)
6922       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
6923       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6924       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
6925       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
6926 C Derivatives in gamma(l-1)
6927       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
6928       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6929       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
6930       vv(1)=pizda(1,1)+pizda(2,2)
6931       vv(2)=pizda(2,1)-pizda(1,2)
6932       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6933       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6934 C Cartesian derivatives.
6935       do iii=1,2
6936         do kkk=1,5
6937           do lll=1,3
6938 #ifdef MOMENT
6939             if (iii.eq.1) then
6940               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
6941             else
6942               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
6943             endif
6944 #endif
6945             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6946      &        auxvec(1))
6947             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6948             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6949      &        auxvec(1))
6950             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6951             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
6952      &        pizda(1,1))
6953             vv(1)=pizda(1,1)+pizda(2,2)
6954             vv(2)=pizda(2,1)-pizda(1,2)
6955             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6956 #ifdef MOMENT
6957             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6958 #else
6959             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6960 #endif
6961             if (swap) then
6962               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6963             else
6964               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6965             endif
6966 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
6967           enddo
6968         enddo
6969       enddo
6970       return
6971       end
6972 c----------------------------------------------------------------------------
6973       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
6974       implicit real*8 (a-h,o-z)
6975       include 'DIMENSIONS'
6976       include 'DIMENSIONS.ZSCOPT'
6977       include 'COMMON.IOUNITS'
6978       include 'COMMON.CHAIN'
6979       include 'COMMON.DERIV'
6980       include 'COMMON.INTERACT'
6981       include 'COMMON.CONTACTS'
6982       include 'COMMON.TORSION'
6983       include 'COMMON.VAR'
6984       include 'COMMON.GEO'
6985       include 'COMMON.FFIELD'
6986       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6987      & auxvec1(2),auxmat1(2,2)
6988       logical swap
6989 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6990 C                                                                              C
6991 C      Parallel       Antiparallel                                             C
6992 C                                                                              C
6993 C          o             o                                                     C
6994 C         /l\   /   \   /j\                                                    C
6995 C        /   \ /     \ /   \                                                   C
6996 C       /| o |o       o| o |\                                                  C
6997 C     \ j|/k\|      \  |/k\|l                                                  C
6998 C      \ /   \       \ /   \                                                   C
6999 C       o     \       o     \                                                  C
7000 C       i             i                                                        C
7001 C                                                                              C
7002 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7003 C
7004 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7005 C           energy moment and not to the cluster cumulant.
7006 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7007       iti=itortyp(itype(i))
7008       itj=itortyp(itype(j))
7009       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7010         itj1=itortyp(itype(j+1))
7011       else
7012         itj1=ntortyp+1
7013       endif
7014       itk=itortyp(itype(k))
7015       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7016         itk1=itortyp(itype(k+1))
7017       else
7018         itk1=ntortyp+1
7019       endif
7020       itl=itortyp(itype(l))
7021       if (l.lt.nres-1) then
7022         itl1=itortyp(itype(l+1))
7023       else
7024         itl1=ntortyp+1
7025       endif
7026 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7027 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7028 cd     & ' itl',itl,' itl1',itl1
7029 #ifdef MOMENT
7030       if (imat.eq.1) then
7031         s1=dip(3,jj,i)*dip(3,kk,k)
7032       else
7033         s1=dip(2,jj,j)*dip(2,kk,l)
7034       endif
7035 #endif
7036       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7037       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7038       if (j.eq.l+1) then
7039         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7040         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7041       else
7042         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7043         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7044       endif
7045       call transpose2(EUg(1,1,k),auxmat(1,1))
7046       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7047       vv(1)=pizda(1,1)-pizda(2,2)
7048       vv(2)=pizda(2,1)+pizda(1,2)
7049       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7050 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7051 #ifdef MOMENT
7052       eello6_graph4=-(s1+s2+s3+s4)
7053 #else
7054       eello6_graph4=-(s2+s3+s4)
7055 #endif
7056       if (.not. calc_grad) return
7057 C Derivatives in gamma(i-1)
7058       if (i.gt.1) then
7059 #ifdef MOMENT
7060         if (imat.eq.1) then
7061           s1=dipderg(2,jj,i)*dip(3,kk,k)
7062         else
7063           s1=dipderg(4,jj,j)*dip(2,kk,l)
7064         endif
7065 #endif
7066         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7067         if (j.eq.l+1) then
7068           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7069           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7070         else
7071           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7072           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7073         endif
7074         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7075         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7076 cd          write (2,*) 'turn6 derivatives'
7077 #ifdef MOMENT
7078           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7079 #else
7080           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7081 #endif
7082         else
7083 #ifdef MOMENT
7084           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7085 #else
7086           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7087 #endif
7088         endif
7089       endif
7090 C Derivatives in gamma(k-1)
7091 #ifdef MOMENT
7092       if (imat.eq.1) then
7093         s1=dip(3,jj,i)*dipderg(2,kk,k)
7094       else
7095         s1=dip(2,jj,j)*dipderg(4,kk,l)
7096       endif
7097 #endif
7098       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7099       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7100       if (j.eq.l+1) then
7101         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7102         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7103       else
7104         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7105         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7106       endif
7107       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7108       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7109       vv(1)=pizda(1,1)-pizda(2,2)
7110       vv(2)=pizda(2,1)+pizda(1,2)
7111       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7112       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7113 #ifdef MOMENT
7114         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7115 #else
7116         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7117 #endif
7118       else
7119 #ifdef MOMENT
7120         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7121 #else
7122         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7123 #endif
7124       endif
7125 C Derivatives in gamma(j-1) or gamma(l-1)
7126       if (l.eq.j+1 .and. l.gt.1) then
7127         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7128         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7129         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7130         vv(1)=pizda(1,1)-pizda(2,2)
7131         vv(2)=pizda(2,1)+pizda(1,2)
7132         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7133         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7134       else if (j.gt.1) then
7135         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7136         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7137         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7138         vv(1)=pizda(1,1)-pizda(2,2)
7139         vv(2)=pizda(2,1)+pizda(1,2)
7140         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7141         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7142           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7143         else
7144           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7145         endif
7146       endif
7147 C Cartesian derivatives.
7148       do iii=1,2
7149         do kkk=1,5
7150           do lll=1,3
7151 #ifdef MOMENT
7152             if (iii.eq.1) then
7153               if (imat.eq.1) then
7154                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7155               else
7156                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7157               endif
7158             else
7159               if (imat.eq.1) then
7160                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7161               else
7162                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7163               endif
7164             endif
7165 #endif
7166             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7167      &        auxvec(1))
7168             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7169             if (j.eq.l+1) then
7170               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7171      &          b1(1,itj1),auxvec(1))
7172               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7173             else
7174               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7175      &          b1(1,itl1),auxvec(1))
7176               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7177             endif
7178             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7179      &        pizda(1,1))
7180             vv(1)=pizda(1,1)-pizda(2,2)
7181             vv(2)=pizda(2,1)+pizda(1,2)
7182             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7183             if (swap) then
7184               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7185 #ifdef MOMENT
7186                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7187      &             -(s1+s2+s4)
7188 #else
7189                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7190      &             -(s2+s4)
7191 #endif
7192                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7193               else
7194 #ifdef MOMENT
7195                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7196 #else
7197                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7198 #endif
7199                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7200               endif
7201             else
7202 #ifdef MOMENT
7203               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7204 #else
7205               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7206 #endif
7207               if (l.eq.j+1) then
7208                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7209               else
7210                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7211               endif
7212             endif
7213           enddo
7214         enddo
7215       enddo
7216       return
7217       end
7218 c----------------------------------------------------------------------------
7219       double precision function eello_turn6(i,jj,kk)
7220       implicit real*8 (a-h,o-z)
7221       include 'DIMENSIONS'
7222       include 'DIMENSIONS.ZSCOPT'
7223       include 'COMMON.IOUNITS'
7224       include 'COMMON.CHAIN'
7225       include 'COMMON.DERIV'
7226       include 'COMMON.INTERACT'
7227       include 'COMMON.CONTACTS'
7228       include 'COMMON.TORSION'
7229       include 'COMMON.VAR'
7230       include 'COMMON.GEO'
7231       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7232      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7233      &  ggg1(3),ggg2(3)
7234       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7235      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7236 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7237 C           the respective energy moment and not to the cluster cumulant.
7238       eello_turn6=0.0d0
7239       j=i+4
7240       k=i+1
7241       l=i+3
7242       iti=itortyp(itype(i))
7243       itk=itortyp(itype(k))
7244       itk1=itortyp(itype(k+1))
7245       itl=itortyp(itype(l))
7246       itj=itortyp(itype(j))
7247 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7248 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7249 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7250 cd        eello6=0.0d0
7251 cd        return
7252 cd      endif
7253 cd      write (iout,*)
7254 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7255 cd     &   ' and',k,l
7256 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7257       do iii=1,2
7258         do kkk=1,5
7259           do lll=1,3
7260             derx_turn(lll,kkk,iii)=0.0d0
7261           enddo
7262         enddo
7263       enddo
7264 cd      eij=1.0d0
7265 cd      ekl=1.0d0
7266 cd      ekont=1.0d0
7267       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7268 cd      eello6_5=0.0d0
7269 cd      write (2,*) 'eello6_5',eello6_5
7270 #ifdef MOMENT
7271       call transpose2(AEA(1,1,1),auxmat(1,1))
7272       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7273       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7274       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7275 #else
7276       s1 = 0.0d0
7277 #endif
7278       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7279       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7280       s2 = scalar2(b1(1,itk),vtemp1(1))
7281 #ifdef MOMENT
7282       call transpose2(AEA(1,1,2),atemp(1,1))
7283       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7284       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7285       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7286 #else
7287       s8=0.0d0
7288 #endif
7289       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7290       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7291       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7292 #ifdef MOMENT
7293       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7294       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7295       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7296       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7297       ss13 = scalar2(b1(1,itk),vtemp4(1))
7298       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7299 #else
7300       s13=0.0d0
7301 #endif
7302 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7303 c      s1=0.0d0
7304 c      s2=0.0d0
7305 c      s8=0.0d0
7306 c      s12=0.0d0
7307 c      s13=0.0d0
7308       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7309       if (calc_grad) then
7310 C Derivatives in gamma(i+2)
7311 #ifdef MOMENT
7312       call transpose2(AEA(1,1,1),auxmatd(1,1))
7313       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7314       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7315       call transpose2(AEAderg(1,1,2),atempd(1,1))
7316       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7317       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7318 #else
7319       s8d=0.0d0
7320 #endif
7321       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7322       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7323       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7324 c      s1d=0.0d0
7325 c      s2d=0.0d0
7326 c      s8d=0.0d0
7327 c      s12d=0.0d0
7328 c      s13d=0.0d0
7329       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7330 C Derivatives in gamma(i+3)
7331 #ifdef MOMENT
7332       call transpose2(AEA(1,1,1),auxmatd(1,1))
7333       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7334       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7335       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7336 #else
7337       s1d=0.0d0
7338 #endif
7339       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7340       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7341       s2d = scalar2(b1(1,itk),vtemp1d(1))
7342 #ifdef MOMENT
7343       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7344       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7345 #endif
7346       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7347 #ifdef MOMENT
7348       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7349       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7350       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7351 #else
7352       s13d=0.0d0
7353 #endif
7354 c      s1d=0.0d0
7355 c      s2d=0.0d0
7356 c      s8d=0.0d0
7357 c      s12d=0.0d0
7358 c      s13d=0.0d0
7359 #ifdef MOMENT
7360       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7361      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7362 #else
7363       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7364      &               -0.5d0*ekont*(s2d+s12d)
7365 #endif
7366 C Derivatives in gamma(i+4)
7367       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7368       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7369       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7370 #ifdef MOMENT
7371       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7372       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7373       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7374 #else
7375       s13d = 0.0d0
7376 #endif
7377 c      s1d=0.0d0
7378 c      s2d=0.0d0
7379 c      s8d=0.0d0
7380 C      s12d=0.0d0
7381 c      s13d=0.0d0
7382 #ifdef MOMENT
7383       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7384 #else
7385       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7386 #endif
7387 C Derivatives in gamma(i+5)
7388 #ifdef MOMENT
7389       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7390       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7391       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7392 #else
7393       s1d = 0.0d0
7394 #endif
7395       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7396       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7397       s2d = scalar2(b1(1,itk),vtemp1d(1))
7398 #ifdef MOMENT
7399       call transpose2(AEA(1,1,2),atempd(1,1))
7400       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7401       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7402 #else
7403       s8d = 0.0d0
7404 #endif
7405       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7406       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7407 #ifdef MOMENT
7408       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7409       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7410       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7411 #else
7412       s13d = 0.0d0
7413 #endif
7414 c      s1d=0.0d0
7415 c      s2d=0.0d0
7416 c      s8d=0.0d0
7417 c      s12d=0.0d0
7418 c      s13d=0.0d0
7419 #ifdef MOMENT
7420       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7421      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7422 #else
7423       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7424      &               -0.5d0*ekont*(s2d+s12d)
7425 #endif
7426 C Cartesian derivatives
7427       do iii=1,2
7428         do kkk=1,5
7429           do lll=1,3
7430 #ifdef MOMENT
7431             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7432             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7433             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7434 #else
7435             s1d = 0.0d0
7436 #endif
7437             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7438             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7439      &          vtemp1d(1))
7440             s2d = scalar2(b1(1,itk),vtemp1d(1))
7441 #ifdef MOMENT
7442             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7443             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7444             s8d = -(atempd(1,1)+atempd(2,2))*
7445      &           scalar2(cc(1,1,itl),vtemp2(1))
7446 #else
7447             s8d = 0.0d0
7448 #endif
7449             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7450      &           auxmatd(1,1))
7451             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7452             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7453 c      s1d=0.0d0
7454 c      s2d=0.0d0
7455 c      s8d=0.0d0
7456 c      s12d=0.0d0
7457 c      s13d=0.0d0
7458 #ifdef MOMENT
7459             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7460      &        - 0.5d0*(s1d+s2d)
7461 #else
7462             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7463      &        - 0.5d0*s2d
7464 #endif
7465 #ifdef MOMENT
7466             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7467      &        - 0.5d0*(s8d+s12d)
7468 #else
7469             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7470      &        - 0.5d0*s12d
7471 #endif
7472           enddo
7473         enddo
7474       enddo
7475 #ifdef MOMENT
7476       do kkk=1,5
7477         do lll=1,3
7478           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7479      &      achuj_tempd(1,1))
7480           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7481           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7482           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7483           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7484           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7485      &      vtemp4d(1))
7486           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7487           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7488           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7489         enddo
7490       enddo
7491 #endif
7492 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7493 cd     &  16*eel_turn6_num
7494 cd      goto 1112
7495       if (j.lt.nres-1) then
7496         j1=j+1
7497         j2=j-1
7498       else
7499         j1=j-1
7500         j2=j-2
7501       endif
7502       if (l.lt.nres-1) then
7503         l1=l+1
7504         l2=l-1
7505       else
7506         l1=l-1
7507         l2=l-2
7508       endif
7509       do ll=1,3
7510         ggg1(ll)=eel_turn6*g_contij(ll,1)
7511         ggg2(ll)=eel_turn6*g_contij(ll,2)
7512         ghalf=0.5d0*ggg1(ll)
7513 cd        ghalf=0.0d0
7514         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7515      &    +ekont*derx_turn(ll,2,1)
7516         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7517         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7518      &    +ekont*derx_turn(ll,4,1)
7519         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7520         ghalf=0.5d0*ggg2(ll)
7521 cd        ghalf=0.0d0
7522         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7523      &    +ekont*derx_turn(ll,2,2)
7524         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7525         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7526      &    +ekont*derx_turn(ll,4,2)
7527         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7528       enddo
7529 cd      goto 1112
7530       do m=i+1,j-1
7531         do ll=1,3
7532           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7533         enddo
7534       enddo
7535       do m=k+1,l-1
7536         do ll=1,3
7537           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7538         enddo
7539       enddo
7540 1112  continue
7541       do m=i+2,j2
7542         do ll=1,3
7543           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7544         enddo
7545       enddo
7546       do m=k+2,l2
7547         do ll=1,3
7548           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7549         enddo
7550       enddo
7551 cd      do iii=1,nres-3
7552 cd        write (2,*) iii,g_corr6_loc(iii)
7553 cd      enddo
7554       endif
7555       eello_turn6=ekont*eel_turn6
7556 cd      write (2,*) 'ekont',ekont
7557 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7558       return
7559       end
7560 crc-------------------------------------------------
7561       SUBROUTINE MATVEC2(A1,V1,V2)
7562       implicit real*8 (a-h,o-z)
7563       include 'DIMENSIONS'
7564       DIMENSION A1(2,2),V1(2),V2(2)
7565 c      DO 1 I=1,2
7566 c        VI=0.0
7567 c        DO 3 K=1,2
7568 c    3     VI=VI+A1(I,K)*V1(K)
7569 c        Vaux(I)=VI
7570 c    1 CONTINUE
7571
7572       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7573       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7574
7575       v2(1)=vaux1
7576       v2(2)=vaux2
7577       END
7578 C---------------------------------------
7579       SUBROUTINE MATMAT2(A1,A2,A3)
7580       implicit real*8 (a-h,o-z)
7581       include 'DIMENSIONS'
7582       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7583 c      DIMENSION AI3(2,2)
7584 c        DO  J=1,2
7585 c          A3IJ=0.0
7586 c          DO K=1,2
7587 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7588 c          enddo
7589 c          A3(I,J)=A3IJ
7590 c       enddo
7591 c      enddo
7592
7593       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7594       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7595       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7596       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7597
7598       A3(1,1)=AI3_11
7599       A3(2,1)=AI3_21
7600       A3(1,2)=AI3_12
7601       A3(2,2)=AI3_22
7602       END
7603
7604 c-------------------------------------------------------------------------
7605       double precision function scalar2(u,v)
7606       implicit none
7607       double precision u(2),v(2)
7608       double precision sc
7609       integer i
7610       scalar2=u(1)*v(1)+u(2)*v(2)
7611       return
7612       end
7613
7614 C-----------------------------------------------------------------------------
7615
7616       subroutine transpose2(a,at)
7617       implicit none
7618       double precision a(2,2),at(2,2)
7619       at(1,1)=a(1,1)
7620       at(1,2)=a(2,1)
7621       at(2,1)=a(1,2)
7622       at(2,2)=a(2,2)
7623       return
7624       end
7625 c--------------------------------------------------------------------------
7626       subroutine transpose(n,a,at)
7627       implicit none
7628       integer n,i,j
7629       double precision a(n,n),at(n,n)
7630       do i=1,n
7631         do j=1,n
7632           at(j,i)=a(i,j)
7633         enddo
7634       enddo
7635       return
7636       end
7637 C---------------------------------------------------------------------------
7638       subroutine prodmat3(a1,a2,kk,transp,prod)
7639       implicit none
7640       integer i,j
7641       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
7642       logical transp
7643 crc      double precision auxmat(2,2),prod_(2,2)
7644
7645       if (transp) then
7646 crc        call transpose2(kk(1,1),auxmat(1,1))
7647 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
7648 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7649
7650            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
7651      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
7652            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
7653      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
7654            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
7655      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
7656            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
7657      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
7658
7659       else
7660 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
7661 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7662
7663            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
7664      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
7665            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
7666      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
7667            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
7668      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
7669            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
7670      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
7671
7672       endif
7673 c      call transpose2(a2(1,1),a2t(1,1))
7674
7675 crc      print *,transp
7676 crc      print *,((prod_(i,j),i=1,2),j=1,2)
7677 crc      print *,((prod(i,j),i=1,2),j=1,2)
7678
7679       return
7680       end
7681 C-----------------------------------------------------------------------------
7682       double precision function scalar(u,v)
7683       implicit none
7684       double precision u(3),v(3)
7685       double precision sc
7686       integer i
7687       sc=0.0d0
7688       do i=1,3
7689         sc=sc+u(i)*v(i)
7690       enddo
7691       scalar=sc
7692       return
7693       end
7694