source/wham/src-NEWSC/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,106) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw,evdw_t)
  34 cd    print '(a)','Exit ELJ'
  35       goto 107
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw,evdw_t)
  38       goto 107
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw,evdw_t)
  41       goto 107
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw,evdw_t)
  44       goto 107
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw,evdw_t)
  47       goto 107
  48 C New SC-SC potential
  49   106 call emomo(evdw,evdw_p,evdw_m)
  50 C
  51 C Calculate electrostatic (H-bonding) energy of the main chain.
  52 C
  53   107 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  54 C
  55 C Calculate excluded-volume interaction energy between peptide groups
  56 C and side chains.
  57 C
  58       call escp(evdw2,evdw2_14)
  59 c
  60 c Calculate the bond-stretching energy
  61 c
  62       call ebond(estr)
  63 c      write (iout,*) "estr",estr
  64 C
  65 C Calculate the disulfide-bridge and other energy and the contributions
  66 C from other distance constraints.
  67 cd    print *,'Calling EHPB'
  68       call edis(ehpb)
  69 cd    print *,'EHPB exitted succesfully.'
  70 C
  71 C Calculate the virtual-bond-angle energy.
  72 C
  73       call ebend(ebe)
  74 cd    print *,'Bend energy finished.'
  75 C
  76 C Calculate the SC local energy.
  77 C
  78       call esc(escloc)
  79 cd    print *,'SCLOC energy finished.'
  80 C
  81 C Calculate the virtual-bond torsional energy.
  82 C
  83 cd    print *,'nterm=',nterm
  84       call etor(etors,edihcnstr,fact(1))
  85 C
  86 C 6/23/01 Calculate double-torsional energy
  87 C
  88       call etor_d(etors_d,fact(2))
  89 C
  90 C 21/5/07 Calculate local sicdechain correlation energy
  91 C
  92       call eback_sc_corr(esccor)
  93 C
  94 C 12/1/95 Multi-body terms
  95 C
  96       n_corr=0
  97       n_corr1=0
  98       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  99      &    .or. wturn6.gt.0.0d0) then
 100 c         print *,"calling multibody_eello"
 101          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 102 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 103 c         print *,ecorr,ecorr5,ecorr6,eturn6
 104       endif
 105       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 106          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 107       endif
 108 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 109 #ifdef SPLITELE
 110       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 111      & +wvdwpp*evdw1
 112      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 113      & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 114      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 115      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 116      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 117      & +wbond*estr+wsccor*fact(1)*esccor
 118 #else
 119       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 120      & +welec*fact(1)*(ees+evdw1)
 121      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 122      & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 123      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 124      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 125      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 126      & +wbond*estr+wsccor*fact(1)*esccor
 127 #endif
 128       energia(0)=etot
 129       energia(1)=evdw
 130 #ifdef SCP14
 131       energia(2)=evdw2-evdw2_14
 132       energia(17)=evdw2_14
 133 #else
 134       energia(2)=evdw2
 135       energia(17)=0.0d0
 136 #endif
 137 #ifdef SPLITELE
 138       energia(3)=ees
 139       energia(16)=evdw1
 140 #else
 141       energia(3)=ees+evdw1
 142       energia(16)=0.0d0
 143 #endif
 144       energia(4)=ecorr
 145       energia(5)=ecorr5
 146       energia(6)=ecorr6
 147       energia(7)=eel_loc
 148       energia(8)=eello_turn3
 149       energia(9)=eello_turn4
 150       energia(10)=eturn6
 151       energia(11)=ebe
 152       energia(12)=escloc
 153       energia(13)=etors
 154       energia(14)=etors_d
 155       energia(15)=ehpb
 156       energia(18)=estr
 157       energia(19)=esccor
 158       energia(20)=edihcnstr
 159       energia(21)=evdw_t
 160 c detecting NaNQ
 161 #ifdef ISNAN
 162 #ifdef AIX
 163       if (isnan(etot).ne.0) energia(0)=1.0d+99
 164 #else
 165       if (isnan(etot)) energia(0)=1.0d+99
 166 #endif
 167 #else
 168       i=0
 169 #ifdef WINPGI
 170       idumm=proc_proc(etot,i)
 171 #else
 172       call proc_proc(etot,i)
 173 #endif
 174       if(i.eq.1)energia(0)=1.0d+99
 175 #endif
 176 #ifdef MPL
 177 c     endif
 178 #endif
 179       if (calc_grad) then
 180 C
 181 C Sum up the components of the Cartesian gradient.
 182 C
 183 #ifdef SPLITELE
 184       do i=1,nct
 185         do j=1,3
 186           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 187      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 188      &                wbond*gradb(j,i)+
 189      &                wstrain*ghpbc(j,i)+
 190      &                wcorr*fact(3)*gradcorr(j,i)+
 191      &                wel_loc*fact(2)*gel_loc(j,i)+
 192      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 193      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 194      &                wcorr5*fact(4)*gradcorr5(j,i)+
 195      &                wcorr6*fact(5)*gradcorr6(j,i)+
 196      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 197      &                wsccor*fact(2)*gsccorc(j,i)
 198           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 199      &                  wbond*gradbx(j,i)+
 200      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 201      &                  wsccor*fact(2)*gsccorx(j,i)
 202         enddo
 203 #else
 204       do i=1,nct
 205         do j=1,3
 206           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 207      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 208      &                wbond*gradb(j,i)+
 209      &                wcorr*fact(3)*gradcorr(j,i)+
 210      &                wel_loc*fact(2)*gel_loc(j,i)+
 211      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 212      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 213      &                wcorr5*fact(4)*gradcorr5(j,i)+
 214      &                wcorr6*fact(5)*gradcorr6(j,i)+
 215      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 216      &                wsccor*fact(2)*gsccorc(j,i)
 217           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 218      &                  wbond*gradbx(j,i)+
 219      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 220      &                  wsccor*fact(1)*gsccorx(j,i)
 221         enddo
 222 #endif
 223       enddo
 224
 225
 226       do i=1,nres-3
 227         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 228      &   +wcorr5*fact(4)*g_corr5_loc(i)
 229      &   +wcorr6*fact(5)*g_corr6_loc(i)
 230      &   +wturn4*fact(3)*gel_loc_turn4(i)
 231      &   +wturn3*fact(2)*gel_loc_turn3(i)
 232      &   +wturn6*fact(5)*gel_loc_turn6(i)
 233      &   +wel_loc*fact(2)*gel_loc_loc(i)
 234      &   +wsccor*fact(1)*gsccor_loc(i)
 235       enddo
 236       endif
 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 #ifdef SPLITELE
 275       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 276      &  wvdwpp,
 277      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 278      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 279      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 280      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 281      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 282      &  esccor,wsccor*fact(1),edihcnstr,ebr*nss,etot
 283    10 format (/'Virtual-chain energies:'//
 284      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 285      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 286      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 287      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 288      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 289      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 290      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 291      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 292      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 293      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 294      & ' (SS bridges & dist. cnstr.)'/
 295      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 296      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 297      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 298      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 299      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 300      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 301      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 302      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 303      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 304      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 305      & 'ETOT=  ',1pE16.6,' (total)')
 306 #else
 307       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 308      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 309      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 310      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 311      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 312      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 313      &  edihcnstr,ebr*nss,etot
 314    10 format (/'Virtual-chain energies:'//
 315      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 316      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 317      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 318      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 319      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 320      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 321      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 322      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 323      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 324      & ' (SS bridges & dist. cnstr.)'/
 325      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 326      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 327      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 328      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 329      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 330      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 331      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 332      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 333      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 334      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 335      & 'ETOT=  ',1pE16.6,' (total)')
 336 #endif
 337       return
 338       end
 339 C-----------------------------------------------------------------------
 340       subroutine elj(evdw,evdw_t)
 341 C
 342 C This subroutine calculates the interaction energy of nonbonded side chains
 343 C assuming the LJ potential of interaction.
 344 C
 345       implicit real*8 (a-h,o-z)
 346       include 'DIMENSIONS'
 347       include 'DIMENSIONS.ZSCOPT'
 348       include "DIMENSIONS.COMPAR"
 349       parameter (accur=1.0d-10)
 350       include 'COMMON.GEO'
 351       include 'COMMON.VAR'
 352       include 'COMMON.LOCAL'
 353       include 'COMMON.CHAIN'
 354       include 'COMMON.DERIV'
 355       include 'COMMON.INTERACT'
 356       include 'COMMON.TORSION'
 357       include 'COMMON.ENEPS'
 358       include 'COMMON.SBRIDGE'
 359       include 'COMMON.NAMES'
 360       include 'COMMON.IOUNITS'
 361       include 'COMMON.CONTACTS'
 362       dimension gg(3)
 363       integer icant
 364       external icant
 365 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 366       do i=1,210
 367         do j=1,2
 368           eneps_temp(j,i)=0.0d0
 369         enddo
 370       enddo
 371       evdw=0.0D0
 372       evdw_t=0.0d0
 373       do i=iatsc_s,iatsc_e
 374         itypi=itype(i)
 375         itypi1=itype(i+1)
 376         xi=c(1,nres+i)
 377         yi=c(2,nres+i)
 378         zi=c(3,nres+i)
 379 C Change 12/1/95
 380         num_conti=0
 381 C
 382 C Calculate SC interaction energy.
 383 C
 384         do iint=1,nint_gr(i)
 385 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 386 cd   &                  'iend=',iend(i,iint)
 387           do j=istart(i,iint),iend(i,iint)
 388             itypj=itype(j)
 389             xj=c(1,nres+j)-xi
 390             yj=c(2,nres+j)-yi
 391             zj=c(3,nres+j)-zi
 392 C Change 12/1/95 to calculate four-body interactions
 393             rij=xj*xj+yj*yj+zj*zj
 394             rrij=1.0D0/rij
 395 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 396             eps0ij=eps(itypi,itypj)
 397             fac=rrij**expon2
 398             e1=fac*fac*aa(itypi,itypj)
 399             e2=fac*bb(itypi,itypj)
 400             evdwij=e1+e2
 401             ij=icant(itypi,itypj)
 402             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 403             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 404 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 405 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 406 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 407 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 408 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 409 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 410             if (bb(itypi,itypj).gt.0.0d0) then
 411               evdw=evdw+evdwij
 412             else
 413               evdw_t=evdw_t+evdwij
 414             endif
 415             if (calc_grad) then
 416 C
 417 C Calculate the components of the gradient in DC and X
 418 C
 419             fac=-rrij*(e1+evdwij)
 420             gg(1)=xj*fac
 421             gg(2)=yj*fac
 422             gg(3)=zj*fac
 423             do k=1,3
 424               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 425               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 426             enddo
 427             do k=i,j-1
 428               do l=1,3
 429                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 430               enddo
 431             enddo
 432             endif
 433 C
 434 C 12/1/95, revised on 5/20/97
 435 C
 436 C Calculate the contact function. The ith column of the array JCONT will
 437 C contain the numbers of atoms that make contacts with the atom I (of numbers
 438 C greater than I). The arrays FACONT and GACONT will contain the values of
 439 C the contact function and its derivative.
 440 C
 441 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 442 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 443 C Uncomment next line, if the correlation interactions are contact function only
 444             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 445               rij=dsqrt(rij)
 446               sigij=sigma(itypi,itypj)
 447               r0ij=rs0(itypi,itypj)
 448 C
 449 C Check whether the SC's are not too far to make a contact.
 450 C
 451               rcut=1.5d0*r0ij
 452               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 453 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 454 C
 455               if (fcont.gt.0.0D0) then
 456 C If the SC-SC distance if close to sigma, apply spline.
 457 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 458 cAdam &             fcont1,fprimcont1)
 459 cAdam           fcont1=1.0d0-fcont1
 460 cAdam           if (fcont1.gt.0.0d0) then
 461 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 462 cAdam             fcont=fcont*fcont1
 463 cAdam           endif
 464 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 465 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 466 cga             do k=1,3
 467 cga               gg(k)=gg(k)*eps0ij
 468 cga             enddo
 469 cga             eps0ij=-evdwij*eps0ij
 470 C Uncomment for AL's type of SC correlation interactions.
 471 cadam           eps0ij=-evdwij
 472                 num_conti=num_conti+1
 473                 jcont(num_conti,i)=j
 474                 facont(num_conti,i)=fcont*eps0ij
 475                 fprimcont=eps0ij*fprimcont/rij
 476                 fcont=expon*fcont
 477 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 478 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 479 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 480 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 481                 gacont(1,num_conti,i)=-fprimcont*xj
 482                 gacont(2,num_conti,i)=-fprimcont*yj
 483                 gacont(3,num_conti,i)=-fprimcont*zj
 484 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 485 cd              write (iout,'(2i3,3f10.5)')
 486 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 487               endif
 488             endif
 489           enddo      ! j
 490         enddo        ! iint
 491 C Change 12/1/95
 492         num_cont(i)=num_conti
 493       enddo          ! i
 494       if (calc_grad) then
 495       do i=1,nct
 496         do j=1,3
 497           gvdwc(j,i)=expon*gvdwc(j,i)
 498           gvdwx(j,i)=expon*gvdwx(j,i)
 499         enddo
 500       enddo
 501       endif
 502 C******************************************************************************
 503 C
 504 C                              N O T E !!!
 505 C
 506 C To save time, the factor of EXPON has been extracted from ALL components
 507 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 508 C use!
 509 C
 510 C******************************************************************************
 511       return
 512       end
 513 C-----------------------------------------------------------------------------
 514       subroutine eljk(evdw,evdw_t)
 515 C
 516 C This subroutine calculates the interaction energy of nonbonded side chains
 517 C assuming the LJK potential of interaction.
 518 C
 519       implicit real*8 (a-h,o-z)
 520       include 'DIMENSIONS'
 521       include 'DIMENSIONS.ZSCOPT'
 522       include "DIMENSIONS.COMPAR"
 523       include 'COMMON.GEO'
 524       include 'COMMON.VAR'
 525       include 'COMMON.LOCAL'
 526       include 'COMMON.CHAIN'
 527       include 'COMMON.DERIV'
 528       include 'COMMON.INTERACT'
 529       include 'COMMON.ENEPS'
 530       include 'COMMON.IOUNITS'
 531       include 'COMMON.NAMES'
 532       dimension gg(3)
 533       logical scheck
 534       integer icant
 535       external icant
 536 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 537       do i=1,210
 538         do j=1,2
 539           eneps_temp(j,i)=0.0d0
 540         enddo
 541       enddo
 542       evdw=0.0D0
 543       evdw_t=0.0d0
 544       do i=iatsc_s,iatsc_e
 545         itypi=itype(i)
 546         itypi1=itype(i+1)
 547         xi=c(1,nres+i)
 548         yi=c(2,nres+i)
 549         zi=c(3,nres+i)
 550 C
 551 C Calculate SC interaction energy.
 552 C
 553         do iint=1,nint_gr(i)
 554           do j=istart(i,iint),iend(i,iint)
 555             itypj=itype(j)
 556             xj=c(1,nres+j)-xi
 557             yj=c(2,nres+j)-yi
 558             zj=c(3,nres+j)-zi
 559             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 560             fac_augm=rrij**expon
 561             e_augm=augm(itypi,itypj)*fac_augm
 562             r_inv_ij=dsqrt(rrij)
 563             rij=1.0D0/r_inv_ij
 564             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 565             fac=r_shift_inv**expon
 566             e1=fac*fac*aa(itypi,itypj)
 567             e2=fac*bb(itypi,itypj)
 568             evdwij=e_augm+e1+e2
 569             ij=icant(itypi,itypj)
 570             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 571      &        /dabs(eps(itypi,itypj))
 572             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 573 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 574 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 575 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 576 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 577 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 578 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 579 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 580             if (bb(itypi,itypj).gt.0.0d0) then
 581               evdw=evdw+evdwij
 582             else
 583               evdw_t=evdw_t+evdwij
 584             endif
 585             if (calc_grad) then
 586 C
 587 C Calculate the components of the gradient in DC and X
 588 C
 589             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 590             gg(1)=xj*fac
 591             gg(2)=yj*fac
 592             gg(3)=zj*fac
 593             do k=1,3
 594               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 595               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 596             enddo
 597             do k=i,j-1
 598               do l=1,3
 599                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 600               enddo
 601             enddo
 602             endif
 603           enddo      ! j
 604         enddo        ! iint
 605       enddo          ! i
 606       if (calc_grad) then
 607       do i=1,nct
 608         do j=1,3
 609           gvdwc(j,i)=expon*gvdwc(j,i)
 610           gvdwx(j,i)=expon*gvdwx(j,i)
 611         enddo
 612       enddo
 613       endif
 614       return
 615       end
 616 C-----------------------------------------------------------------------------
 617       subroutine ebp(evdw,evdw_t)
 618 C
 619 C This subroutine calculates the interaction energy of nonbonded side chains
 620 C assuming the Berne-Pechukas potential of interaction.
 621 C
 622       implicit real*8 (a-h,o-z)
 623       include 'DIMENSIONS'
 624       include 'DIMENSIONS.ZSCOPT'
 625       include "DIMENSIONS.COMPAR"
 626       include 'COMMON.GEO'
 627       include 'COMMON.VAR'
 628       include 'COMMON.LOCAL'
 629       include 'COMMON.CHAIN'
 630       include 'COMMON.DERIV'
 631       include 'COMMON.NAMES'
 632       include 'COMMON.INTERACT'
 633       include 'COMMON.ENEPS'
 634       include 'COMMON.IOUNITS'
 635       include 'COMMON.CALC'
 636       common /srutu/ icall
 637 c     double precision rrsave(maxdim)
 638       logical lprn
 639       integer icant
 640       external icant
 641       do i=1,210
 642         do j=1,2
 643           eneps_temp(j,i)=0.0d0
 644         enddo
 645       enddo
 646       evdw=0.0D0
 647       evdw_t=0.0d0
 648 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 649 c     if (icall.eq.0) then
 650 c       lprn=.true.
 651 c     else
 652         lprn=.false.
 653 c     endif
 654       ind=0
 655       do i=iatsc_s,iatsc_e
 656         itypi=itype(i)
 657         itypi1=itype(i+1)
 658         xi=c(1,nres+i)
 659         yi=c(2,nres+i)
 660         zi=c(3,nres+i)
 661         dxi=dc_norm(1,nres+i)
 662         dyi=dc_norm(2,nres+i)
 663         dzi=dc_norm(3,nres+i)
 664         dsci_inv=vbld_inv(i+nres)
 665 C
 666 C Calculate SC interaction energy.
 667 C
 668         do iint=1,nint_gr(i)
 669           do j=istart(i,iint),iend(i,iint)
 670             ind=ind+1
 671             itypj=itype(j)
 672             dscj_inv=vbld_inv(j+nres)
 673             chi1=chi(itypi,itypj)
 674             chi2=chi(itypj,itypi)
 675             chi12=chi1*chi2
 676             chip1=chip(itypi)
 677             chip2=chip(itypj)
 678             chip12=chip1*chip2
 679             alf1=alp(itypi)
 680             alf2=alp(itypj)
 681             alf12=0.5D0*(alf1+alf2)
 682 C For diagnostics only!!!
 683 c           chi1=0.0D0
 684 c           chi2=0.0D0
 685 c           chi12=0.0D0
 686 c           chip1=0.0D0
 687 c           chip2=0.0D0
 688 c           chip12=0.0D0
 689 c           alf1=0.0D0
 690 c           alf2=0.0D0
 691 c           alf12=0.0D0
 692             xj=c(1,nres+j)-xi
 693             yj=c(2,nres+j)-yi
 694             zj=c(3,nres+j)-zi
 695             dxj=dc_norm(1,nres+j)
 696             dyj=dc_norm(2,nres+j)
 697             dzj=dc_norm(3,nres+j)
 698             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 699 cd          if (icall.eq.0) then
 700 cd            rrsave(ind)=rrij
 701 cd          else
 702 cd            rrij=rrsave(ind)
 703 cd          endif
 704             rij=dsqrt(rrij)
 705 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 706             call sc_angular
 707 C Calculate whole angle-dependent part of epsilon and contributions
 708 C to its derivatives
 709             fac=(rrij*sigsq)**expon2
 710             e1=fac*fac*aa(itypi,itypj)
 711             e2=fac*bb(itypi,itypj)
 712             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 713             eps2der=evdwij*eps3rt
 714             eps3der=evdwij*eps2rt
 715             evdwij=evdwij*eps2rt*eps3rt
 716             ij=icant(itypi,itypj)
 717             aux=eps1*eps2rt**2*eps3rt**2
 718             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 719      &        /dabs(eps(itypi,itypj))
 720             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 721             if (bb(itypi,itypj).gt.0.0d0) then
 722               evdw=evdw+evdwij
 723             else
 724               evdw_t=evdw_t+evdwij
 725             endif
 726             if (calc_grad) then
 727             if (lprn) then
 728             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 729             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 730 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 731 cd     &        restyp(itypi),i,restyp(itypj),j,
 732 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 733 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 734 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 735 cd     &        evdwij
 736             endif
 737 C Calculate gradient components.
 738             e1=e1*eps1*eps2rt**2*eps3rt**2
 739             fac=-expon*(e1+evdwij)
 740             sigder=fac/sigsq
 741             fac=rrij*fac
 742 C Calculate radial part of the gradient
 743             gg(1)=xj*fac
 744             gg(2)=yj*fac
 745             gg(3)=zj*fac
 746 C Calculate the angular part of the gradient and sum add the contributions
 747 C to the appropriate components of the Cartesian gradient.
 748             call sc_grad
 749             endif
 750           enddo      ! j
 751         enddo        ! iint
 752       enddo          ! i
 753 c     stop
 754       return
 755       end
 756 C-----------------------------------------------------------------------------
 757       subroutine egb(evdw,evdw_t)
 758 C
 759 C This subroutine calculates the interaction energy of nonbonded side chains
 760 C assuming the Gay-Berne potential of interaction.
 761 C
 762       implicit real*8 (a-h,o-z)
 763       include 'DIMENSIONS'
 764       include 'DIMENSIONS.ZSCOPT'
 765       include "DIMENSIONS.COMPAR"
 766       include 'COMMON.GEO'
 767       include 'COMMON.VAR'
 768       include 'COMMON.LOCAL'
 769       include 'COMMON.CHAIN'
 770       include 'COMMON.DERIV'
 771       include 'COMMON.NAMES'
 772       include 'COMMON.INTERACT'
 773       include 'COMMON.ENEPS'
 774       include 'COMMON.IOUNITS'
 775       include 'COMMON.CALC'
 776       logical lprn
 777       common /srutu/icall
 778       integer icant
 779       external icant
 780       do i=1,210
 781         do j=1,2
 782           eneps_temp(j,i)=0.0d0
 783         enddo
 784       enddo
 785 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 786       evdw=0.0D0
 787       evdw_t=0.0d0
 788       lprn=.false.
 789 c      if (icall.gt.0) lprn=.true.
 790       ind=0
 791       do i=iatsc_s,iatsc_e
 792         itypi=itype(i)
 793         itypi1=itype(i+1)
 794         xi=c(1,nres+i)
 795         yi=c(2,nres+i)
 796         zi=c(3,nres+i)
 797         dxi=dc_norm(1,nres+i)
 798         dyi=dc_norm(2,nres+i)
 799         dzi=dc_norm(3,nres+i)
 800         dsci_inv=vbld_inv(i+nres)
 801 C
 802 C Calculate SC interaction energy.
 803 C
 804         do iint=1,nint_gr(i)
 805           do j=istart(i,iint),iend(i,iint)
 806             ind=ind+1
 807             itypj=itype(j)
 808             dscj_inv=vbld_inv(j+nres)
 809             sig0ij=sigma(itypi,itypj)
 810             chi1=chi(itypi,itypj)
 811             chi2=chi(itypj,itypi)
 812             chi12=chi1*chi2
 813             chip1=chip(itypi)
 814             chip2=chip(itypj)
 815             chip12=chip1*chip2
 816             alf1=alp(itypi)
 817             alf2=alp(itypj)
 818             alf12=0.5D0*(alf1+alf2)
 819 C For diagnostics only!!!
 820 c           chi1=0.0D0
 821 c           chi2=0.0D0
 822 c           chi12=0.0D0
 823 c           chip1=0.0D0
 824 c           chip2=0.0D0
 825 c           chip12=0.0D0
 826 c           alf1=0.0D0
 827 c           alf2=0.0D0
 828 c           alf12=0.0D0
 829             xj=c(1,nres+j)-xi
 830             yj=c(2,nres+j)-yi
 831             zj=c(3,nres+j)-zi
 832             dxj=dc_norm(1,nres+j)
 833             dyj=dc_norm(2,nres+j)
 834             dzj=dc_norm(3,nres+j)
 835 c            write (iout,*) i,j,xj,yj,zj
 836             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 837             rij=dsqrt(rrij)
 838 C Calculate angle-dependent terms of energy and contributions to their
 839 C derivatives.
 840             call sc_angular
 841             sigsq=1.0D0/sigsq
 842             sig=sig0ij*dsqrt(sigsq)
 843             rij_shift=1.0D0/rij-sig+sig0ij
 844 C I hate to put IF's in the loops, but here don't have another choice!!!!
 845             if (rij_shift.le.0.0D0) then
 846               evdw=1.0D20
 847               return
 848             endif
 849             sigder=-sig*sigsq
 850 c---------------------------------------------------------------
 851             rij_shift=1.0D0/rij_shift
 852             fac=rij_shift**expon
 853             e1=fac*fac*aa(itypi,itypj)
 854             e2=fac*bb(itypi,itypj)
 855             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 856             eps2der=evdwij*eps3rt
 857             eps3der=evdwij*eps2rt
 858             evdwij=evdwij*eps2rt*eps3rt
 859             if (bb(itypi,itypj).gt.0) then
 860               evdw=evdw+evdwij
 861             else
 862               evdw_t=evdw_t+evdwij
 863             endif
 864             ij=icant(itypi,itypj)
 865             aux=eps1*eps2rt**2*eps3rt**2
 866             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 867      &        /dabs(eps(itypi,itypj))
 868             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 869 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 870 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 871 c     &         aux*e2/eps(itypi,itypj)
 872             if (lprn) then
 873             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 874             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 875             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 876      &        restyp(itypi),i,restyp(itypj),j,
 877      &        epsi,sigm,chi1,chi2,chip1,chip2,
 878      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 879      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 880      &        evdwij
 881             endif
 882             if (calc_grad) then
 883 C Calculate gradient components.
 884             e1=e1*eps1*eps2rt**2*eps3rt**2
 885             fac=-expon*(e1+evdwij)*rij_shift
 886             sigder=fac*sigder
 887             fac=rij*fac
 888 C Calculate the radial part of the gradient
 889             gg(1)=xj*fac
 890             gg(2)=yj*fac
 891             gg(3)=zj*fac
 892 C Calculate angular part of the gradient.
 893             call sc_grad
 894             endif
 895           enddo      ! j
 896         enddo        ! iint
 897       enddo          ! i
 898       return
 899       end
 900 C-----------------------------------------------------------------------------
 901       subroutine egbv(evdw,evdw_t)
 902 C
 903 C This subroutine calculates the interaction energy of nonbonded side chains
 904 C assuming the Gay-Berne-Vorobjev potential of interaction.
 905 C
 906       implicit real*8 (a-h,o-z)
 907       include 'DIMENSIONS'
 908       include 'DIMENSIONS.ZSCOPT'
 909       include "DIMENSIONS.COMPAR"
 910       include 'COMMON.GEO'
 911       include 'COMMON.VAR'
 912       include 'COMMON.LOCAL'
 913       include 'COMMON.CHAIN'
 914       include 'COMMON.DERIV'
 915       include 'COMMON.NAMES'
 916       include 'COMMON.INTERACT'
 917       include 'COMMON.ENEPS'
 918       include 'COMMON.IOUNITS'
 919       include 'COMMON.CALC'
 920       common /srutu/ icall
 921       logical lprn
 922       integer icant
 923       external icant
 924       do i=1,210
 925         do j=1,2
 926           eneps_temp(j,i)=0.0d0
 927         enddo
 928       enddo
 929       evdw=0.0D0
 930       evdw_t=0.0d0
 931 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 932       evdw=0.0D0
 933       lprn=.false.
 934 c      if (icall.gt.0) lprn=.true.
 935       ind=0
 936       do i=iatsc_s,iatsc_e
 937         itypi=itype(i)
 938         itypi1=itype(i+1)
 939         xi=c(1,nres+i)
 940         yi=c(2,nres+i)
 941         zi=c(3,nres+i)
 942         dxi=dc_norm(1,nres+i)
 943         dyi=dc_norm(2,nres+i)
 944         dzi=dc_norm(3,nres+i)
 945         dsci_inv=vbld_inv(i+nres)
 946 C
 947 C Calculate SC interaction energy.
 948 C
 949         do iint=1,nint_gr(i)
 950           do j=istart(i,iint),iend(i,iint)
 951             ind=ind+1
 952             itypj=itype(j)
 953             dscj_inv=vbld_inv(j+nres)
 954             sig0ij=sigma(itypi,itypj)
 955             r0ij=r0(itypi,itypj)
 956             chi1=chi(itypi,itypj)
 957             chi2=chi(itypj,itypi)
 958             chi12=chi1*chi2
 959             chip1=chip(itypi)
 960             chip2=chip(itypj)
 961             chip12=chip1*chip2
 962             alf1=alp(itypi)
 963             alf2=alp(itypj)
 964             alf12=0.5D0*(alf1+alf2)
 965 C For diagnostics only!!!
 966 c           chi1=0.0D0
 967 c           chi2=0.0D0
 968 c           chi12=0.0D0
 969 c           chip1=0.0D0
 970 c           chip2=0.0D0
 971 c           chip12=0.0D0
 972 c           alf1=0.0D0
 973 c           alf2=0.0D0
 974 c           alf12=0.0D0
 975             xj=c(1,nres+j)-xi
 976             yj=c(2,nres+j)-yi
 977             zj=c(3,nres+j)-zi
 978             dxj=dc_norm(1,nres+j)
 979             dyj=dc_norm(2,nres+j)
 980             dzj=dc_norm(3,nres+j)
 981             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 982             rij=dsqrt(rrij)
 983 C Calculate angle-dependent terms of energy and contributions to their
 984 C derivatives.
 985             call sc_angular
 986             sigsq=1.0D0/sigsq
 987             sig=sig0ij*dsqrt(sigsq)
 988             rij_shift=1.0D0/rij-sig+r0ij
 989 C I hate to put IF's in the loops, but here don't have another choice!!!!
 990             if (rij_shift.le.0.0D0) then
 991               evdw=1.0D20
 992               return
 993             endif
 994             sigder=-sig*sigsq
 995 c---------------------------------------------------------------
 996             rij_shift=1.0D0/rij_shift
 997             fac=rij_shift**expon
 998             e1=fac*fac*aa(itypi,itypj)
 999             e2=fac*bb(itypi,itypj)
1000             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1001             eps2der=evdwij*eps3rt
1002             eps3der=evdwij*eps2rt
1003             fac_augm=rrij**expon
1004             e_augm=augm(itypi,itypj)*fac_augm
1005             evdwij=evdwij*eps2rt*eps3rt
1006             if (bb(itypi,itypj).gt.0.0d0) then
1007               evdw=evdw+evdwij+e_augm
1008             else
1009               evdw_t=evdw_t+evdwij+e_augm
1010             endif
1011             ij=icant(itypi,itypj)
1012             aux=eps1*eps2rt**2*eps3rt**2
1013             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1014      &        /dabs(eps(itypi,itypj))
1015             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1016 c            eneps_temp(ij)=eneps_temp(ij)
1017 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1018 c            if (lprn) then
1019 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1020 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1021 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1022 c     &        restyp(itypi),i,restyp(itypj),j,
1023 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1024 c     &        chi1,chi2,chip1,chip2,
1025 c     &        eps1,eps2rt**2,eps3rt**2,
1026 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1027 c     &        evdwij+e_augm
1028 c            endif
1029             if (calc_grad) then
1030 C Calculate gradient components.
1031             e1=e1*eps1*eps2rt**2*eps3rt**2
1032             fac=-expon*(e1+evdwij)*rij_shift
1033             sigder=fac*sigder
1034             fac=rij*fac-2*expon*rrij*e_augm
1035 C Calculate the radial part of the gradient
1036             gg(1)=xj*fac
1037             gg(2)=yj*fac
1038             gg(3)=zj*fac
1039 C Calculate angular part of the gradient.
1040             call sc_grad
1041             endif
1042           enddo      ! j
1043         enddo        ! iint
1044       enddo          ! i
1045       return
1046       end
1047 C-----------------------------------------------------------------------------
1048
1049
1050       SUBROUTINE emomo(evdw,evdw_p,evdw_m)
1051 C
1052 C This subroutine calculates the interaction energy of nonbonded side chains
1053 C assuming the Gay-Berne potential of interaction.
1054 C
1055        IMPLICIT NONE
1056        INCLUDE 'DIMENSIONS'
1057        INCLUDE 'DIMENSIONS.ZSCOPT'
1058        INCLUDE 'COMMON.CALC'
1059        INCLUDE 'COMMON.CONTROL'
1060        INCLUDE 'COMMON.CHAIN'
1061        INCLUDE 'COMMON.DERIV'
1062        INCLUDE 'COMMON.EMP'
1063        INCLUDE 'COMMON.GEO'
1064        INCLUDE 'COMMON.INTERACT'
1065        INCLUDE 'COMMON.IOUNITS'
1066        INCLUDE 'COMMON.LOCAL'
1067        INCLUDE 'COMMON.NAMES'
1068        INCLUDE 'COMMON.VAR'
1069        logical lprn
1070        double precision scalar
1071        double precision ener(4)
1072        integer troll,iint
1073
1074 <<<<<<< HEAD
1075        energy_dec=.false.
1076 =======
1077 >>>>>>> e183793... Added src_MD-M-newcorr (Adasko's source) and src-NEWSC of WHAM (with Momo's SCSC potentials)
1078        IF (energy_dec) write (iout,'(a)')
1079      & ' AAi i  AAj  j  1/rij  Rtail   Rhead   evdwij   Fcav   Ecl
1080      & Egb   Epol   Fisocav   Elj   Equad   evdw'
1081        evdw   = 0.0D0
1082        evdw_p = 0.0D0
1083        evdw_m = 0.0D0
1084 c DIAGNOSTICS
1085 ccccc      energy_dec=.false.
1086 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1087 c      lprn   = .false.
1088 c     if (icall.eq.0) lprn=.false.
1089 c END DIAGNOSTICS
1090 c      ind = 0
1091        DO i = iatsc_s, iatsc_e
1092         itypi  = itype(i)
1093 c        itypi1 = itype(i+1)
1094         dxi    = dc_norm(1,nres+i)
1095         dyi    = dc_norm(2,nres+i)
1096         dzi    = dc_norm(3,nres+i)
1097 c        dsci_inv=dsc_inv(itypi)
1098         dsci_inv = vbld_inv(i+nres)
1099 c        DO k = 1, 3
1100 c         ctail(k,1) = c(k, i+nres)
1101 c     &              - dtail(1,itypi,itypj) * dc_norm(k, nres+i)
1102 c        END DO
1103         xi=c(1,nres+i)
1104         yi=c(2,nres+i)
1105         zi=c(3,nres+i)
1106 c!-------------------------------------------------------------------
1107 C Calculate SC interaction energy.
1108         DO iint = 1, nint_gr(i)
1109          DO j = istart(i,iint), iend(i,iint)
1110 c! initialize variables for electrostatic gradients
1111           CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
1112 c            ind=ind+1
1113 c            dscj_inv = dsc_inv(itypj)
1114           dscj_inv = vbld_inv(j+nres)
1115 c! rij holds 1/(distance of Calpha atoms)
1116           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
1117           rij  = dsqrt(rrij)
1118 c!-------------------------------------------------------------------
1119 C Calculate angle-dependent terms of energy and contributions to their
1120 C derivatives.
1121
1122 #IFDEF CHECK_MOMO
1123 c!      DO troll = 10, 5000
1124 c!      om1    = 0.0d0
1125 c!      om2    = 0.0d0
1126 c!      om12   = 1.0d0
1127 c!      sqom1  = om1 * om1
1128 c!      sqom2  = om2 * om2
1129 c!      sqom12 = om12 * om12
1130 c!      rij    = 5.0d0 / troll
1131 c!      rrij   = rij * rij
1132 c!      Rtail  = troll / 5.0d0
1133 c!      Rhead  = troll / 5.0d0
1134 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1135 c!      Rtail = dsqrt((Rtail**2)
1136 c!     &      +((dabs(dtail(1,itypi,itypj)-dtail(2,itypi,itypj)))**2))
1137 c!      rij = 1.0d0/Rtail
1138 c!      rrij = rij * rij
1139 #ENDIF
1140           CALL sc_angular
1141 c! this should be in elgrad_init but om's are calculated by sc_angular
1142 c! which in turn is used by older potentials
1143 c! which proves how tangled UNRES code is >.<
1144 c! om = omega, sqom = om^2
1145           sqom1  = om1 * om1
1146           sqom2  = om2 * om2
1147           sqom12 = om12 * om12
1148
1149 c! now we calculate EGB - Gey-Berne
1150 c! It will be summed up in evdwij and saved in evdw
1151           sigsq     = 1.0D0  / sigsq
1152           sig       = sig0ij * dsqrt(sigsq)
1153 c!          rij_shift = 1.0D0  / rij - sig + sig0ij
1154           rij_shift = Rtail - sig + sig0ij
1155 c          write (2,*) "Rtal",Rtail," sig",sig," sigsq",sigsq,
1156 c     &       " sig0ij",sig0ij
1157 c          write (2,*) "rij_shift",rij_shift
1158           IF (rij_shift.le.0.0D0) THEN
1159            evdw = 1.0D20
1160            RETURN
1161           END IF
1162           sigder = -sig * sigsq
1163           rij_shift = 1.0D0 / rij_shift
1164           fac       = rij_shift**expon
1165           c1        = fac  * fac * aa(itypi,itypj)
1166 <<<<<<< HEAD
1167 =======
1168 #ifdef SCALREP
1169 ! Scale down the repulsive term for 1,4 interactions.
1170           if (iabs(j-i).le.4) c1  = 0.01d0 * c1
1171 #endif
1172 >>>>>>> e183793... Added src_MD-M-newcorr (Adasko's source) and src-NEWSC of WHAM (with Momo's SCSC potentials)
1173 c!          c1        = 0.0d0
1174           c2        = fac  * bb(itypi,itypj)
1175 c!          c2        = 0.0d0
1176 c          write (2,*) "eps1",eps1," eps2rt",eps2rt," eps3rt",eps3rt,
1177 c     &     " c1",c1," c2",c2
1178           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
1179           eps2der   = eps3rt * evdwij
1180           eps3der   = eps2rt * evdwij
1181 c!          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
1182           evdwij    = eps2rt * eps3rt * evdwij
1183 c!      evdwij = 0.0d0
1184 c!      write (*,*) "Gey Berne = ", evdwij
1185 #ifdef TSCSC
1186           IF (bb(itypi,itypj).gt.0) THEN
1187            evdw_p = evdw_p + evdwij
1188           ELSE
1189            evdw_m = evdw_m + evdwij
1190           END IF
1191 #else
1192           evdw = evdw
1193      &         + evdwij
1194 #endif
1195 c!-------------------------------------------------------------------
1196 c! Calculate some components of GGB
1197           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
1198           fac    = -expon * (c1 + evdwij) * rij_shift
1199           sigder = fac * sigder
1200 c!          fac    = rij * fac
1201 c! Calculate distance derivative
1202 c!          gg(1) = xj * fac
1203 c!          gg(2) = yj * fac
1204 c!          gg(3) = zj * fac
1205           gg(1) = fac
1206           gg(2) = fac
1207           gg(3) = fac
1208 c!      write (*,*) "gg(1) = ", gg(1)
1209 c!      write (*,*) "gg(2) = ", gg(2)
1210 c!      write (*,*) "gg(3) = ", gg(3)
1211 c! The angular derivatives of GGB are brought together in sc_grad
1212 c!-------------------------------------------------------------------
1213 c! Fcav
1214 c!
1215 c! Catch gly-gly interactions to skip calculation of something that
1216 c! does not exist
1217
1218       IF (itypi.eq.10.and.itypj.eq.10) THEN
1219        Fcav = 0.0d0
1220        dFdR = 0.0d0
1221        dCAVdOM1  = 0.0d0
1222        dCAVdOM2  = 0.0d0
1223        dCAVdOM12 = 0.0d0
1224       ELSE
1225
1226 c! we are not 2 glycines, so we calculate Fcav (and maybe more)
1227        fac = chis1 * sqom1 + chis2 * sqom2
1228      &     - 2.0d0 * chis12 * om1 * om2 * om12
1229 c! we will use pom later in Gcav, so dont mess with it!
1230        pom = 1.0d0 - chis1 * chis2 * sqom12
1231
1232        Lambf = (1.0d0 - (fac / pom))
1233        Lambf = dsqrt(Lambf)
1234
1235
1236        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
1237 c!       write (*,*) "sparrow = ", sparrow
1238        Chif = Rtail * sparrow
1239        ChiLambf = Chif * Lambf
1240        eagle = dsqrt(ChiLambf)
1241        bat = ChiLambf ** 11.0d0
1242
1243        top = b1 * ( eagle + b2 * ChiLambf - b3 )
1244        bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
1245        botsq = bot * bot
1246
1247 c!      write (*,*) "sig1 = ",sig1
1248 c!      write (*,*) "sig2 = ",sig2
1249 c!      write (*,*) "Rtail = ",Rtail
1250 c!      write (*,*) "sparrow = ",sparrow
1251 c!      write (*,*) "Chis1 = ", chis1
1252 c!      write (*,*) "Chis2 = ", chis2
1253 c!      write (*,*) "Chis12 = ", chis12
1254 c!      write (*,*) "om1 = ", om1
1255 c!      write (*,*) "om2 = ", om2
1256 c!      write (*,*) "om12 = ", om12
1257 c!      write (*,*) "sqom1 = ", sqom1
1258 c!      write (*,*) "sqom2 = ", sqom2
1259 c!      write (*,*) "sqom12 = ", sqom12
1260 c!      write (*,*) "Lambf = ",Lambf
1261 c!      write (*,*) "b1 = ",b1
1262 c!      write (*,*) "b2 = ",b2
1263 c!      write (*,*) "b3 = ",b3
1264 c!      write (*,*) "b4 = ",b4
1265 c!      write (*,*) "top = ",top
1266 c!      write (*,*) "bot = ",bot
1267        Fcav = top / bot
1268 c!       Fcav = 0.0d0
1269 c!      write (*,*) "Fcav = ", Fcav
1270 c!-------------------------------------------------------------------
1271 c! derivative of Fcav is Gcav...
1272 c!---------------------------------------------------
1273
1274        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
1275        dbot = 12.0d0 * b4 * bat * Lambf
1276        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
1277 c!       dFdR = 0.0d0
1278 c!      write (*,*) "dFcav/dR = ", dFdR
1279
1280        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
1281        dbot = 12.0d0 * b4 * bat * Chif
1282        eagle = Lambf * pom
1283        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
1284        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
1285        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)
1286      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)
1287
1288        dFdL = ((dtop * bot - top * dbot) / botsq)
1289 c!       dFdL = 0.0d0
1290        dCAVdOM1  = dFdL * ( dFdOM1 )
1291        dCAVdOM2  = dFdL * ( dFdOM2 )
1292        dCAVdOM12 = dFdL * ( dFdOM12 )
1293 c!      write (*,*) "dFcav/dOM1 = ", dCAVdOM1
1294 c!      write (*,*) "dFcav/dOM2 = ", dCAVdOM2
1295 c!      write (*,*) "dFcav/dOM12 = ", dCAVdOM12
1296 c!      write (*,*) ""
1297 c!-------------------------------------------------------------------
1298 c! Finally, add the distance derivatives of GB and Fcav to gvdwc
1299 c! Pom is used here to project the gradient vector into
1300 c! cartesian coordinates and at the same time contains
1301 c! dXhb/dXsc derivative (for charged amino acids
1302 c! location of hydrophobic centre of interaction is not
1303 c! the same as geometric centre of side chain, this
1304 c! derivative takes that into account)
1305 c! derivatives of omega angles will be added in sc_grad
1306
1307        DO k= 1, 3
1308         ertail(k) = Rtail_distance(k)/Rtail
1309        END DO
1310        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
1311        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
1312        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1313        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1314        DO k = 1, 3
1315 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1316 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1317         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
1318         gvdwx(k,i) = gvdwx(k,i)
1319      &             - (( dFdR + gg(k) ) * pom)
1320 c!     &             - ( dFdR * pom )
1321         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
1322         gvdwx(k,j) = gvdwx(k,j)
1323      &             + (( dFdR + gg(k) ) * pom)
1324 c!     &             + ( dFdR * pom )
1325
1326         gvdwc(k,i) = gvdwc(k,i)
1327      &             - (( dFdR + gg(k) ) * ertail(k))
1328 c!     &             - ( dFdR * ertail(k))
1329
1330         gvdwc(k,j) = gvdwc(k,j)
1331      &             + (( dFdR + gg(k) ) * ertail(k))
1332 c!     &             + ( dFdR * ertail(k))
1333
1334         gg(k) = 0.0d0
1335 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1336 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1337       END DO
1338
1339 c!-------------------------------------------------------------------
1340 c! Compute head-head and head-tail energies for each state
1341
1342           isel = iabs(Qi) + iabs(Qj)
1343           IF (isel.eq.0) THEN
1344 c! No charges - do nothing
1345            eheadtail = 0.0d0
1346
1347           ELSE IF (isel.eq.4) THEN
1348 c! Calculate dipole-dipole interactions
1349            CALL edd(ecl)
1350            eheadtail = ECL
1351
1352           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
1353 c! Charge-nonpolar interactions
1354            CALL eqn(epol)
1355            eheadtail = epol
1356
1357           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
1358 c! Nonpolar-charge interactions
1359            CALL enq(epol)
1360            eheadtail = epol
1361
1362           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
1363 c! Charge-dipole interactions
1364            CALL eqd(ecl, elj, epol)
1365            eheadtail = ECL + elj + epol
1366
1367           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
1368 c! Dipole-charge interactions
1369            CALL edq(ecl, elj, epol)
1370            eheadtail = ECL + elj + epol
1371
1372           ELSE IF ((isel.eq.2.and.
1373      &          iabs(Qi).eq.1).and.
1374      &          nstate(itypi,itypj).eq.1) THEN
1375 c! Same charge-charge interaction ( +/+ or -/- )
1376            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
1377            eheadtail = ECL + Egb + Epol + Fisocav + Elj
1378
1379           ELSE IF ((isel.eq.2.and.
1380      &          iabs(Qi).eq.1).and.
1381      &          nstate(itypi,itypj).ne.1) THEN
1382 c! Different charge-charge interaction ( +/- or -/+ )
1383            CALL energy_quad
1384      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1385           END IF
1386        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
1387 c!      write (*,*) "evdw = ", evdw
1388 c!      write (*,*) "Fcav = ", Fcav
1389 c!      write (*,*) "eheadtail = ", eheadtail
1390        evdw = evdw
1391      &      + Fcav
1392      &      + eheadtail
1393
1394 <<<<<<< HEAD
1395        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,9f16.7)')
1396      &  restyp(itype(i)),i,restyp(itype(j)),j,
1397      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1398      &  Equad,evdw
1399        IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
1400      &  restyp(itype(i)),i,restyp(itype(j)),j,
1401      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1402      &  Equad,evdw
1403 =======
1404        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)')
1405      &  restyp(itype(i)),i,restyp(itype(j)),j,
1406      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1407      &  Equad,evdwij+Fcav+eheadtail,evdw
1408 c       IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
1409 c     &  restyp(itype(i)),i,restyp(itype(j)),j,
1410 c     &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1411 c     &  Equad,evdwij+Fcav+eheadtail,evdw
1412 >>>>>>> e183793... Added src_MD-M-newcorr (Adasko's source) and src-NEWSC of WHAM (with Momo's SCSC potentials)
1413 #IFDEF CHECK_MOMO
1414        evdw = 0.0d0
1415        END DO ! troll
1416 #ENDIF
1417
1418 c!-------------------------------------------------------------------
1419 c! As all angular derivatives are done, now we sum them up,
1420 c! then transform and project into cartesian vectors and add to gvdwc
1421 c! We call sc_grad always, with the exception of +/- interaction.
1422 c! This is because energy_quad subroutine needs to handle
1423 c! this job in his own way.
1424 c! This IS probably not very efficient and SHOULD be optimised
1425 c! but it will require major restructurization of emomo
1426 c! so it will be left as it is for now
1427 c!       write (*,*) 'troll1, nstate =', nstate (itypi,itypj)
1428        IF (nstate(itypi,itypj).eq.1) THEN
1429 #ifdef TSCSC
1430         IF (bb(itypi,itypj).gt.0) THEN
1431          CALL sc_grad
1432         ELSE
1433          CALL sc_grad_T
1434         END IF
1435 #else
1436         CALL sc_grad
1437 #endif
1438        END IF
1439 c!-------------------------------------------------------------------
1440 c! NAPISY KONCOWE
1441          END DO   ! j
1442         END DO    ! iint
1443        END DO     ! i
1444 <<<<<<< HEAD
1445 =======
1446        if (energy_dec) write (iout,*) "evdw before exiting emomo:",evdw
1447 >>>>>>> e183793... Added src_MD-M-newcorr (Adasko's source) and src-NEWSC of WHAM (with Momo's SCSC potentials)
1448 c      write (iout,*) "Number of loop steps in EGB:",ind
1449 c      energy_dec=.false.
1450        RETURN
1451       END SUBROUTINE emomo
1452 c! END OF MOMO
1453
1454
1455 C-----------------------------------------------------------------------------
1456
1457
1458       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
1459        IMPLICIT NONE
1460        INCLUDE 'DIMENSIONS'
1461        INCLUDE 'DIMENSIONS.ZSCOPT'
1462        INCLUDE 'COMMON.CALC'
1463        INCLUDE 'COMMON.CHAIN'
1464        INCLUDE 'COMMON.CONTROL'
1465        INCLUDE 'COMMON.DERIV'
1466        INCLUDE 'COMMON.EMP'
1467        INCLUDE 'COMMON.GEO'
1468        INCLUDE 'COMMON.INTERACT'
1469        INCLUDE 'COMMON.IOUNITS'
1470        INCLUDE 'COMMON.LOCAL'
1471        INCLUDE 'COMMON.NAMES'
1472        INCLUDE 'COMMON.VAR'
1473        double precision scalar, facd3, facd4, federmaus, adler
1474 c! Epol and Gpol analytical parameters
1475        alphapol1 = alphapol(itypi,itypj)
1476        alphapol2 = alphapol(itypj,itypi)
1477 c! Fisocav and Gisocav analytical parameters
1478        al1  = alphiso(1,itypi,itypj)
1479        al2  = alphiso(2,itypi,itypj)
1480        al3  = alphiso(3,itypi,itypj)
1481        al4  = alphiso(4,itypi,itypj)
1482        csig = (1.0d0
1483      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1484      &      + sigiso2(itypi,itypj)**2.0d0))
1485 c!
1486        pis  = sig0head(itypi,itypj)
1487        eps_head = epshead(itypi,itypj)
1488        Rhead_sq = Rhead * Rhead
1489 c! R1 - distance between head of ith side chain and tail of jth sidechain
1490 c! R2 - distance between head of jth side chain and tail of ith sidechain
1491        R1 = 0.0d0
1492        R2 = 0.0d0
1493        DO k = 1, 3
1494 c! Calculate head-to-tail distances needed by Epol
1495         R1=R1+(ctail(k,2)-chead(k,1))**2
1496         R2=R2+(chead(k,2)-ctail(k,1))**2
1497        END DO
1498 c! Pitagoras
1499        R1 = dsqrt(R1)
1500        R2 = dsqrt(R2)
1501
1502 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1503 c!     &        +dhead(1,1,itypi,itypj))**2))
1504 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1505 c!     &        +dhead(2,1,itypi,itypj))**2))
1506
1507 c!-------------------------------------------------------------------
1508 c! Coulomb electrostatic interaction
1509        Ecl = (332.0d0 * Qij) / Rhead
1510 c! derivative of Ecl is Gcl...
1511        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
1512        dGCLdOM1 = 0.0d0
1513        dGCLdOM2 = 0.0d0
1514        dGCLdOM12 = 0.0d0
1515 c!-------------------------------------------------------------------
1516 c! Generalised Born Solvent Polarization
1517 c! Charged head polarizes the solvent
1518        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1519        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1520        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1521 c! Derivative of Egb is Ggb...
1522        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1523        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1524      &        / ( 2.0d0 * Fgb )
1525        dGGBdR = dGGBdFGB * dFGBdR
1526 c!-------------------------------------------------------------------
1527 c! Fisocav - isotropic cavity creation term
1528 c! or "how much energy it costs to put charged head in water"
1529        pom = Rhead * csig
1530        top = al1 * (dsqrt(pom) + al2 * pom - al3)
1531        bot = (1.0d0 + al4 * pom**12.0d0)
1532        botsq = bot * bot
1533        FisoCav = top / bot
1534 c!      write (*,*) "Rhead = ",Rhead
1535 c!      write (*,*) "csig = ",csig
1536 c!      write (*,*) "pom = ",pom
1537 c!      write (*,*) "al1 = ",al1
1538 c!      write (*,*) "al2 = ",al2
1539 c!      write (*,*) "al3 = ",al3
1540 c!      write (*,*) "al4 = ",al4
1541 c!      write (*,*) "top = ",top
1542 c!      write (*,*) "bot = ",bot
1543 c! Derivative of Fisocav is GCV...
1544        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1545        dbot = 12.0d0 * al4 * pom ** 11.0d0
1546        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1547 c!-------------------------------------------------------------------
1548 c! Epol
1549 c! Polarization energy - charged heads polarize hydrophobic "neck"
1550        MomoFac1 = (1.0d0 - chi1 * sqom2)
1551        MomoFac2 = (1.0d0 - chi2 * sqom1)
1552        RR1  = ( R1 * R1 ) / MomoFac1
1553        RR2  = ( R2 * R2 ) / MomoFac2
1554        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1555        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1556        fgb1 = sqrt( RR1 + a12sq * ee1 )
1557        fgb2 = sqrt( RR2 + a12sq * ee2 )
1558        epol = 332.0d0 * eps_inout_fac * (
1559      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1560 c!       epol = 0.0d0
1561 c       write (*,*) "eps_inout_fac = ",eps_inout_fac
1562 c       write (*,*) "alphapol1 = ", alphapol1
1563 c       write (*,*) "alphapol2 = ", alphapol2
1564 c       write (*,*) "fgb1 = ", fgb1
1565 c       write (*,*) "fgb2 = ", fgb2
1566 c       write (*,*) "epol = ", epol
1567 c! derivative of Epol is Gpol...
1568        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1569      &          / (fgb1 ** 5.0d0)
1570        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1571      &          / (fgb2 ** 5.0d0)
1572        dFGBdR1 = ( (R1 / MomoFac1)
1573      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
1574      &        / ( 2.0d0 * fgb1 )
1575        dFGBdR2 = ( (R2 / MomoFac2)
1576      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
1577      &        / ( 2.0d0 * fgb2 )
1578        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1579      &          * ( 2.0d0 - 0.5d0 * ee1) )
1580      &          / ( 2.0d0 * fgb1 )
1581        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1582      &          * ( 2.0d0 - 0.5d0 * ee2) )
1583      &          / ( 2.0d0 * fgb2 )
1584        dPOLdR1 = dPOLdFGB1 * dFGBdR1
1585 c!       dPOLdR1 = 0.0d0
1586        dPOLdR2 = dPOLdFGB2 * dFGBdR2
1587 c!       dPOLdR2 = 0.0d0
1588        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1589 c!       dPOLdOM1 = 0.0d0
1590        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1591 c!       dPOLdOM2 = 0.0d0
1592 c!-------------------------------------------------------------------
1593 c! Elj
1594 c! Lennard-Jones 6-12 interaction between heads
1595        pom = (pis / Rhead)**6.0d0
1596        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1597 c! derivative of Elj is Glj
1598        dGLJdR = 4.0d0 * eps_head
1599      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1600      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1601 c!-------------------------------------------------------------------
1602 c! Return the results
1603 c! These things do the dRdX derivatives, that is
1604 c! allow us to change what we see from function that changes with
1605 c! distance to function that changes with LOCATION (of the interaction
1606 c! site)
1607        DO k = 1, 3
1608         erhead(k) = Rhead_distance(k)/Rhead
1609         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1610         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1611        END DO
1612
1613        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1614        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1615        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1616        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1617        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1618        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1619        facd1 = d1 * vbld_inv(i+nres)
1620        facd2 = d2 * vbld_inv(j+nres)
1621        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1622        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1623
1624 c! Now we add appropriate partial derivatives (one in each dimension)
1625        DO k = 1, 3
1626         hawk   = (erhead_tail(k,1) +
1627      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
1628         condor = (erhead_tail(k,2) +
1629      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
1630
1631         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1632         gvdwx(k,i) = gvdwx(k,i)
1633      &             - dGCLdR * pom
1634      &             - dGGBdR * pom
1635      &             - dGCVdR * pom
1636      &             - dPOLdR1 * hawk
1637      &             - dPOLdR2 * (erhead_tail(k,2)
1638      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1639      &             - dGLJdR * pom
1640
1641         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1642         gvdwx(k,j) = gvdwx(k,j)
1643      &             + dGCLdR * pom
1644      &             + dGGBdR * pom
1645      &             + dGCVdR * pom
1646      &             + dPOLdR1 * (erhead_tail(k,1)
1647      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1648      &             + dPOLdR2 * condor
1649      &             + dGLJdR * pom
1650
1651         gvdwc(k,i) = gvdwc(k,i)
1652      &             - dGCLdR * erhead(k)
1653      &             - dGGBdR * erhead(k)
1654      &             - dGCVdR * erhead(k)
1655      &             - dPOLdR1 * erhead_tail(k,1)
1656      &             - dPOLdR2 * erhead_tail(k,2)
1657      &             - dGLJdR * erhead(k)
1658
1659         gvdwc(k,j) = gvdwc(k,j)
1660      &             + dGCLdR * erhead(k)
1661      &             + dGGBdR * erhead(k)
1662      &             + dGCVdR * erhead(k)
1663      &             + dPOLdR1 * erhead_tail(k,1)
1664      &             + dPOLdR2 * erhead_tail(k,2)
1665      &             + dGLJdR * erhead(k)
1666
1667        END DO
1668        RETURN
1669       END SUBROUTINE eqq
1670 c!-------------------------------------------------------------------
1671       SUBROUTINE energy_quad
1672      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1673        IMPLICIT NONE
1674        INCLUDE 'DIMENSIONS'
1675        INCLUDE 'DIMENSIONS.ZSCOPT'
1676        INCLUDE 'COMMON.CALC'
1677        INCLUDE 'COMMON.CHAIN'
1678        INCLUDE 'COMMON.CONTROL'
1679        INCLUDE 'COMMON.DERIV'
1680        INCLUDE 'COMMON.EMP'
1681        INCLUDE 'COMMON.GEO'
1682        INCLUDE 'COMMON.INTERACT'
1683        INCLUDE 'COMMON.IOUNITS'
1684        INCLUDE 'COMMON.LOCAL'
1685        INCLUDE 'COMMON.NAMES'
1686        INCLUDE 'COMMON.VAR'
1687        double precision scalar
1688        double precision ener(4)
1689        double precision dcosom1(3),dcosom2(3)
1690 c! used in Epol derivatives
1691        double precision facd3, facd4
1692        double precision federmaus, adler
1693 c! Epol and Gpol analytical parameters
1694        alphapol1 = alphapol(itypi,itypj)
1695        alphapol2 = alphapol(itypj,itypi)
1696 c! Fisocav and Gisocav analytical parameters
1697        al1  = alphiso(1,itypi,itypj)
1698        al2  = alphiso(2,itypi,itypj)
1699        al3  = alphiso(3,itypi,itypj)
1700        al4  = alphiso(4,itypi,itypj)
1701        csig = (1.0d0
1702      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1703      &      + sigiso2(itypi,itypj)**2.0d0))
1704 c!
1705        w1   = wqdip(1,itypi,itypj)
1706        w2   = wqdip(2,itypi,itypj)
1707        pis  = sig0head(itypi,itypj)
1708        eps_head = epshead(itypi,itypj)
1709 c! First things first:
1710 c! We need to do sc_grad's job with GB and Fcav
1711        eom1  =
1712      &         eps2der * eps2rt_om1
1713      &       - 2.0D0 * alf1 * eps3der
1714      &       + sigder * sigsq_om1
1715      &       + dCAVdOM1
1716        eom2  =
1717      &         eps2der * eps2rt_om2
1718      &       + 2.0D0 * alf2 * eps3der
1719      &       + sigder * sigsq_om2
1720      &       + dCAVdOM2
1721        eom12 =
1722      &         evdwij  * eps1_om12
1723      &       + eps2der * eps2rt_om12
1724      &       - 2.0D0 * alf12 * eps3der
1725      &       + sigder *sigsq_om12
1726      &       + dCAVdOM12
1727 c! now some magical transformations to project gradient into
1728 c! three cartesian vectors
1729        DO k = 1, 3
1730         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1731         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1732         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
1733 c! this acts on hydrophobic center of interaction
1734         gvdwx(k,i)= gvdwx(k,i) - gg(k)
1735      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1736      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1737         gvdwx(k,j)= gvdwx(k,j) + gg(k)
1738      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1739      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1740 c! this acts on Calpha
1741         gvdwc(k,i)=gvdwc(k,i)-gg(k)
1742         gvdwc(k,j)=gvdwc(k,j)+gg(k)
1743        END DO
1744 c! sc_grad is done, now we will compute
1745        eheadtail = 0.0d0
1746        eom1 = 0.0d0
1747        eom2 = 0.0d0
1748        eom12 = 0.0d0
1749
1750 c! ENERGY DEBUG
1751 c!       ii = 1
1752 c!       jj = 1
1753 c!       d1 = dhead(1, 1, itypi, itypj)
1754 c!       d2 = dhead(2, 1, itypi, itypj)
1755 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1756 c!     &        +dhead(1,ii,itypi,itypj))**2))
1757 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1758 c!     &        +dhead(2,jj,itypi,itypj))**2))
1759 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1760 c! END OF ENERGY DEBUG
1761 c*************************************************************
1762        DO istate = 1, nstate(itypi,itypj)
1763 c*************************************************************
1764         IF (istate.ne.1) THEN
1765          IF (istate.lt.3) THEN
1766           ii = 1
1767          ELSE
1768           ii = 2
1769          END IF
1770         jj = istate/ii
1771         d1 = dhead(1,ii,itypi,itypj)
1772         d2 = dhead(2,jj,itypi,itypj)
1773         DO k = 1,3
1774          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
1775          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
1776          Rhead_distance(k) = chead(k,2) - chead(k,1)
1777         END DO
1778 c! pitagoras (root of sum of squares)
1779         Rhead = dsqrt(
1780      &          (Rhead_distance(1)*Rhead_distance(1))
1781      &        + (Rhead_distance(2)*Rhead_distance(2))
1782      &        + (Rhead_distance(3)*Rhead_distance(3)))
1783         END IF
1784         Rhead_sq = Rhead * Rhead
1785
1786 c! R1 - distance between head of ith side chain and tail of jth sidechain
1787 c! R2 - distance between head of jth side chain and tail of ith sidechain
1788         R1 = 0.0d0
1789         R2 = 0.0d0
1790         DO k = 1, 3
1791 c! Calculate head-to-tail distances
1792          R1=R1+(ctail(k,2)-chead(k,1))**2
1793          R2=R2+(chead(k,2)-ctail(k,1))**2
1794         END DO
1795 c! Pitagoras
1796         R1 = dsqrt(R1)
1797         R2 = dsqrt(R2)
1798
1799 c! ENERGY DEBUG
1800 c!      write (*,*) "istate = ", istate
1801 c!      write (*,*) "ii = ", ii
1802 c!      write (*,*) "jj = ", jj
1803 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1804 c!     &        +dhead(1,ii,itypi,itypj))**2))
1805 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1806 c!     &        +dhead(2,jj,itypi,itypj))**2))
1807 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1808 c!      Rhead_sq = Rhead * Rhead
1809 c!      write (*,*) "d1 = ",d1
1810 c!      write (*,*) "d2 = ",d2
1811 c!      write (*,*) "R1 = ",R1
1812 c!      write (*,*) "R2 = ",R2
1813 c!      write (*,*) "Rhead = ",Rhead
1814 c! END OF ENERGY DEBUG
1815
1816 c!-------------------------------------------------------------------
1817 c! Coulomb electrostatic interaction
1818         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
1819 c!        Ecl = 0.0d0
1820 c!        write (*,*) "Ecl = ", Ecl
1821 c! derivative of Ecl is Gcl...
1822         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
1823 c!        dGCLdR = 0.0d0
1824         dGCLdOM1 = 0.0d0
1825         dGCLdOM2 = 0.0d0
1826         dGCLdOM12 = 0.0d0
1827 c!-------------------------------------------------------------------
1828 c! Generalised Born Solvent Polarization
1829         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1830         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1831         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1832 c!        Egb = 0.0d0
1833 c!      write (*,*) "a1*a2 = ", a12sq
1834 c!      write (*,*) "Rhead = ", Rhead
1835 c!      write (*,*) "Rhead_sq = ", Rhead_sq
1836 c!      write (*,*) "ee = ", ee
1837 c!      write (*,*) "Fgb = ", Fgb
1838 c!      write (*,*) "fac = ", eps_inout_fac
1839 c!      write (*,*) "Qij = ", Qij
1840 c!      write (*,*) "Egb = ", Egb
1841 c! Derivative of Egb is Ggb...
1842 c! dFGBdR is used by Quad's later...
1843         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1844         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1845      &         / ( 2.0d0 * Fgb )
1846         dGGBdR = dGGBdFGB * dFGBdR
1847 c!        dGGBdR = 0.0d0
1848 c!-------------------------------------------------------------------
1849 c! Fisocav - isotropic cavity creation term
1850         pom = Rhead * csig
1851         top = al1 * (dsqrt(pom) + al2 * pom - al3)
1852         bot = (1.0d0 + al4 * pom**12.0d0)
1853         botsq = bot * bot
1854         FisoCav = top / bot
1855 c!        FisoCav = 0.0d0
1856 c!      write (*,*) "pom = ",pom
1857 c!      write (*,*) "al1 = ",al1
1858 c!      write (*,*) "al2 = ",al2
1859 c!      write (*,*) "al3 = ",al3
1860 c!      write (*,*) "al4 = ",al4
1861 c!      write (*,*) "top = ",top
1862 c!      write (*,*) "bot = ",bot
1863 c!      write (*,*) "Fisocav = ", Fisocav
1864
1865 c! Derivative of Fisocav is GCV...
1866         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1867         dbot = 12.0d0 * al4 * pom ** 11.0d0
1868         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1869 c!        dGCVdR = 0.0d0
1870 c!-------------------------------------------------------------------
1871 c! Polarization energy
1872 c! Epol
1873         MomoFac1 = (1.0d0 - chi1 * sqom2)
1874         MomoFac2 = (1.0d0 - chi2 * sqom1)
1875         RR1  = ( R1 * R1 ) / MomoFac1
1876         RR2  = ( R2 * R2 ) / MomoFac2
1877         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1878         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1879         fgb1 = sqrt( RR1 + a12sq * ee1 )
1880         fgb2 = sqrt( RR2 + a12sq * ee2 )
1881         epol = 332.0d0 * eps_inout_fac * (
1882      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1883 c!        epol = 0.0d0
1884 c! derivative of Epol is Gpol...
1885         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1886      &            / (fgb1 ** 5.0d0)
1887         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1888      &            / (fgb2 ** 5.0d0)
1889         dFGBdR1 = ( (R1 / MomoFac1)
1890      &          * ( 2.0d0 - (0.5d0 * ee1) ) )
1891      &          / ( 2.0d0 * fgb1 )
1892         dFGBdR2 = ( (R2 / MomoFac2)
1893      &          * ( 2.0d0 - (0.5d0 * ee2) ) )
1894      &          / ( 2.0d0 * fgb2 )
1895         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1896      &           * ( 2.0d0 - 0.5d0 * ee1) )
1897      &           / ( 2.0d0 * fgb1 )
1898         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1899      &           * ( 2.0d0 - 0.5d0 * ee2) )
1900      &           / ( 2.0d0 * fgb2 )
1901         dPOLdR1 = dPOLdFGB1 * dFGBdR1
1902 c!        dPOLdR1 = 0.0d0
1903         dPOLdR2 = dPOLdFGB2 * dFGBdR2
1904 c!        dPOLdR2 = 0.0d0
1905         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1906 c!        dPOLdOM1 = 0.0d0
1907         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1908 c!        dPOLdOM2 = 0.0d0
1909 c!-------------------------------------------------------------------
1910 c! Elj
1911         pom = (pis / Rhead)**6.0d0
1912         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1913 c!        Elj = 0.0d0
1914 c! derivative of Elj is Glj
1915         dGLJdR = 4.0d0 * eps_head
1916      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1917      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1918 c!        dGLJdR = 0.0d0
1919 c!-------------------------------------------------------------------
1920 c! Equad
1921        IF (Wqd.ne.0.0d0) THEN
1922         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)
1923      &        - 37.5d0  * ( sqom1 + sqom2 )
1924      &        + 157.5d0 * ( sqom1 * sqom2 )
1925      &        - 45.0d0  * om1*om2*om12
1926         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
1927         Equad = fac * Beta1
1928 c!        Equad = 0.0d0
1929 c! derivative of Equad...
1930         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
1931 c!        dQUADdR = 0.0d0
1932         dQUADdOM1 = fac
1933      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
1934 c!        dQUADdOM1 = 0.0d0
1935         dQUADdOM2 = fac
1936      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
1937 c!        dQUADdOM2 = 0.0d0
1938         dQUADdOM12 = fac
1939      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )
1940 c!        dQUADdOM12 = 0.0d0
1941         ELSE
1942          Beta1 = 0.0d0
1943          Equad = 0.0d0
1944         END IF
1945 c!-------------------------------------------------------------------
1946 c! Return the results
1947 c! Angular stuff
1948         eom1 = dPOLdOM1 + dQUADdOM1
1949         eom2 = dPOLdOM2 + dQUADdOM2
1950         eom12 = dQUADdOM12
1951 c! now some magical transformations to project gradient into
1952 c! three cartesian vectors
1953         DO k = 1, 3
1954          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1955          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1956          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
1957         END DO
1958 c! Radial stuff
1959         DO k = 1, 3
1960          erhead(k) = Rhead_distance(k)/Rhead
1961          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1962          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1963         END DO
1964         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1965         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1966         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1967         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1968         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1969         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1970         facd1 = d1 * vbld_inv(i+nres)
1971         facd2 = d2 * vbld_inv(j+nres)
1972         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1973         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1974 c! Throw the results into gheadtail which holds gradients
1975 c! for each micro-state
1976         DO k = 1, 3
1977          hawk   = erhead_tail(k,1) +
1978      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
1979          condor = erhead_tail(k,2) +
1980      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
1981
1982          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1983 c! this acts on hydrophobic center of interaction
1984          gheadtail(k,1,1) = gheadtail(k,1,1)
1985      &                    - dGCLdR * pom
1986      &                    - dGGBdR * pom
1987      &                    - dGCVdR * pom
1988      &                    - dPOLdR1 * hawk
1989      &                    - dPOLdR2 * (erhead_tail(k,2)
1990      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1991      &                    - dGLJdR * pom
1992      &                    - dQUADdR * pom
1993      &                    - tuna(k)
1994      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1995      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1996
1997          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1998 c! this acts on hydrophobic center of interaction
1999          gheadtail(k,2,1) = gheadtail(k,2,1)
2000      &                    + dGCLdR * pom
2001      &                    + dGGBdR * pom
2002      &                    + dGCVdR * pom
2003      &                    + dPOLdR1 * (erhead_tail(k,1)
2004      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2005      &                    + dPOLdR2 * condor
2006      &                    + dGLJdR * pom
2007      &                    + dQUADdR * pom
2008      &                    + tuna(k)
2009      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2010      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2011
2012 c! this acts on Calpha
2013          gheadtail(k,3,1) = gheadtail(k,3,1)
2014      &                    - dGCLdR * erhead(k)
2015      &                    - dGGBdR * erhead(k)
2016      &                    - dGCVdR * erhead(k)
2017      &                    - dPOLdR1 * erhead_tail(k,1)
2018      &                    - dPOLdR2 * erhead_tail(k,2)
2019      &                    - dGLJdR * erhead(k)
2020      &                    - dQUADdR * erhead(k)
2021      &                    - tuna(k)
2022
2023 c! this acts on Calpha
2024          gheadtail(k,4,1) = gheadtail(k,4,1)
2025      &                    + dGCLdR * erhead(k)
2026      &                    + dGGBdR * erhead(k)
2027      &                    + dGCVdR * erhead(k)
2028      &                    + dPOLdR1 * erhead_tail(k,1)
2029      &                    + dPOLdR2 * erhead_tail(k,2)
2030      &                    + dGLJdR * erhead(k)
2031      &                    + dQUADdR * erhead(k)
2032      &                    + tuna(k)
2033         END DO
2034 c!      write(*,*) "ECL = ", Ecl
2035 c!      write(*,*) "Egb = ", Egb
2036 c!      write(*,*) "Epol = ", Epol
2037 c!      write(*,*) "Fisocav = ", Fisocav
2038 c!      write(*,*) "Elj = ", Elj
2039 c!      write(*,*) "Equad = ", Equad
2040 c!      write(*,*) "wstate = ", wstate(istate,itypi,itypj)
2041 c!      write(*,*) "eheadtail = ", eheadtail
2042 c!      write(*,*) "TROLL = ", dexp(-betaT * ener(istate))
2043 c!      write(*,*) "dGCLdR = ", dGCLdR
2044 c!      write(*,*) "dGGBdR = ", dGGBdR
2045 c!      write(*,*) "dGCVdR = ", dGCVdR
2046 c!      write(*,*) "dPOLdR1 = ", dPOLdR1
2047 c!      write(*,*) "dPOLdR2 = ", dPOLdR2
2048 c!      write(*,*) "dGLJdR = ", dGLJdR
2049 c!      write(*,*) "dQUADdR = ", dQUADdR
2050 c!      write(*,*) "tuna(",k,") = ", tuna(k)
2051         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
2052         eheadtail = eheadtail
2053      &            + wstate(istate, itypi, itypj)
2054      &            * dexp(-betaT * ener(istate))
2055 c! foreach cartesian dimension
2056         DO k = 1, 3
2057 c! foreach of two gvdwx and gvdwc
2058          DO l = 1, 4
2059           gheadtail(k,l,2) = gheadtail(k,l,2)
2060      &                     + wstate( istate, itypi, itypj )
2061      &                     * dexp(-betaT * ener(istate))
2062      &                     * gheadtail(k,l,1)
2063           gheadtail(k,l,1) = 0.0d0
2064          END DO
2065         END DO
2066        END DO
2067 c! Here ended the gigantic DO istate = 1, 4, which starts
2068 c! at the beggining of the subroutine
2069
2070        DO k = 1, 3
2071         DO l = 1, 4
2072          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
2073         END DO
2074         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
2075         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
2076         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
2077         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
2078         DO l = 1, 4
2079          gheadtail(k,l,1) = 0.0d0
2080          gheadtail(k,l,2) = 0.0d0
2081         END DO
2082        END DO
2083        eheadtail = (-dlog(eheadtail)) / betaT
2084        dPOLdOM1 = 0.0d0
2085        dPOLdOM2 = 0.0d0
2086        dQUADdOM1 = 0.0d0
2087        dQUADdOM2 = 0.0d0
2088        dQUADdOM12 = 0.0d0
2089        RETURN
2090       END SUBROUTINE energy_quad
2091
2092
2093 c!-------------------------------------------------------------------
2094
2095
2096       SUBROUTINE eqn(Epol)
2097       IMPLICIT NONE
2098       INCLUDE 'DIMENSIONS'
2099       INCLUDE 'DIMENSIONS.ZSCOPT'
2100       INCLUDE 'COMMON.CALC'
2101       INCLUDE 'COMMON.CHAIN'
2102       INCLUDE 'COMMON.CONTROL'
2103       INCLUDE 'COMMON.DERIV'
2104       INCLUDE 'COMMON.EMP'
2105       INCLUDE 'COMMON.GEO'
2106       INCLUDE 'COMMON.INTERACT'
2107       INCLUDE 'COMMON.IOUNITS'
2108       INCLUDE 'COMMON.LOCAL'
2109       INCLUDE 'COMMON.NAMES'
2110       INCLUDE 'COMMON.VAR'
2111       double precision scalar, facd4, federmaus
2112       alphapol1 = alphapol(itypi,itypj)
2113 c! R1 - distance between head of ith side chain and tail of jth sidechain
2114        R1 = 0.0d0
2115        DO k = 1, 3
2116 c! Calculate head-to-tail distances
2117         R1=R1+(ctail(k,2)-chead(k,1))**2
2118        END DO
2119 c! Pitagoras
2120        R1 = dsqrt(R1)
2121
2122 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2123 c!     &        +dhead(1,1,itypi,itypj))**2))
2124 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2125 c!     &        +dhead(2,1,itypi,itypj))**2))
2126 c--------------------------------------------------------------------
2127 c Polarization energy
2128 c Epol
2129        MomoFac1 = (1.0d0 - chi1 * sqom2)
2130        RR1  = R1 * R1 / MomoFac1
2131        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2132        fgb1 = sqrt( RR1 + a12sq * ee1)
2133        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2134 c!       epol = 0.0d0
2135 c!------------------------------------------------------------------
2136 c! derivative of Epol is Gpol...
2137        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2138      &          / (fgb1 ** 5.0d0)
2139        dFGBdR1 = ( (R1 / MomoFac1)
2140      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2141      &        / ( 2.0d0 * fgb1 )
2142        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2143      &          * (2.0d0 - 0.5d0 * ee1) )
2144      &          / (2.0d0 * fgb1)
2145        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2146 c!       dPOLdR1 = 0.0d0
2147        dPOLdOM1 = 0.0d0
2148        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2149 c!       dPOLdOM2 = 0.0d0
2150 c!-------------------------------------------------------------------
2151 c! Return the results
2152 c! (see comments in Eqq)
2153        DO k = 1, 3
2154         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2155        END DO
2156        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2157        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2158        facd1 = d1 * vbld_inv(i+nres)
2159        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2160
2161        DO k = 1, 3
2162         hawk = (erhead_tail(k,1) +
2163      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2164
2165         gvdwx(k,i) = gvdwx(k,i)
2166      &             - dPOLdR1 * hawk
2167         gvdwx(k,j) = gvdwx(k,j)
2168      &             + dPOLdR1 * (erhead_tail(k,1)
2169      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2170
2171         gvdwc(k,i) = gvdwc(k,i)
2172      &             - dPOLdR1 * erhead_tail(k,1)
2173         gvdwc(k,j) = gvdwc(k,j)
2174      &             + dPOLdR1 * erhead_tail(k,1)
2175
2176        END DO
2177        RETURN
2178       END SUBROUTINE eqn
2179
2180
2181 c!-------------------------------------------------------------------
2182
2183
2184
2185       SUBROUTINE enq(Epol)
2186        IMPLICIT NONE
2187        INCLUDE 'DIMENSIONS'
2188        INCLUDE 'DIMENSIONS.ZSCOPT'
2189        INCLUDE 'COMMON.CALC'
2190        INCLUDE 'COMMON.CHAIN'
2191        INCLUDE 'COMMON.CONTROL'
2192        INCLUDE 'COMMON.DERIV'
2193        INCLUDE 'COMMON.EMP'
2194        INCLUDE 'COMMON.GEO'
2195        INCLUDE 'COMMON.INTERACT'
2196        INCLUDE 'COMMON.IOUNITS'
2197        INCLUDE 'COMMON.LOCAL'
2198        INCLUDE 'COMMON.NAMES'
2199        INCLUDE 'COMMON.VAR'
2200        double precision scalar, facd3, adler
2201        alphapol2 = alphapol(itypj,itypi)
2202 c! R2 - distance between head of jth side chain and tail of ith sidechain
2203        R2 = 0.0d0
2204        DO k = 1, 3
2205 c! Calculate head-to-tail distances
2206         R2=R2+(chead(k,2)-ctail(k,1))**2
2207        END DO
2208 c! Pitagoras
2209        R2 = dsqrt(R2)
2210
2211 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2212 c!     &        +dhead(1,1,itypi,itypj))**2))
2213 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2214 c!     &        +dhead(2,1,itypi,itypj))**2))
2215 c------------------------------------------------------------------------
2216 c Polarization energy
2217        MomoFac2 = (1.0d0 - chi2 * sqom1)
2218        RR2  = R2 * R2 / MomoFac2
2219        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2220        fgb2 = sqrt(RR2  + a12sq * ee2)
2221        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2222 c!       epol = 0.0d0
2223 c!-------------------------------------------------------------------
2224 c! derivative of Epol is Gpol...
2225        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2226      &          / (fgb2 ** 5.0d0)
2227        dFGBdR2 = ( (R2 / MomoFac2)
2228      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2229      &        / (2.0d0 * fgb2)
2230        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2231      &          * (2.0d0 - 0.5d0 * ee2) )
2232      &          / (2.0d0 * fgb2)
2233        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2234 c!       dPOLdR2 = 0.0d0
2235        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2236 c!       dPOLdOM1 = 0.0d0
2237        dPOLdOM2 = 0.0d0
2238 c!-------------------------------------------------------------------
2239 c! Return the results
2240 c! (See comments in Eqq)
2241        DO k = 1, 3
2242         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2243        END DO
2244        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2245        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2246        facd2 = d2 * vbld_inv(j+nres)
2247        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2248        DO k = 1, 3
2249         condor = (erhead_tail(k,2)
2250      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2251
2252         gvdwx(k,i) = gvdwx(k,i)
2253      &             - dPOLdR2 * (erhead_tail(k,2)
2254      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2255         gvdwx(k,j) = gvdwx(k,j)
2256      &             + dPOLdR2 * condor
2257
2258         gvdwc(k,i) = gvdwc(k,i)
2259      &             - dPOLdR2 * erhead_tail(k,2)
2260         gvdwc(k,j) = gvdwc(k,j)
2261      &             + dPOLdR2 * erhead_tail(k,2)
2262
2263        END DO
2264       RETURN
2265       END SUBROUTINE enq
2266
2267
2268 c!-------------------------------------------------------------------
2269
2270
2271       SUBROUTINE eqd(Ecl,Elj,Epol)
2272        IMPLICIT NONE
2273        INCLUDE 'DIMENSIONS'
2274        INCLUDE 'DIMENSIONS.ZSCOPT'
2275        INCLUDE 'COMMON.CALC'
2276        INCLUDE 'COMMON.CHAIN'
2277        INCLUDE 'COMMON.CONTROL'
2278        INCLUDE 'COMMON.DERIV'
2279        INCLUDE 'COMMON.EMP'
2280        INCLUDE 'COMMON.GEO'
2281        INCLUDE 'COMMON.INTERACT'
2282        INCLUDE 'COMMON.IOUNITS'
2283        INCLUDE 'COMMON.LOCAL'
2284        INCLUDE 'COMMON.NAMES'
2285        INCLUDE 'COMMON.VAR'
2286        double precision scalar, facd4, federmaus
2287        alphapol1 = alphapol(itypi,itypj)
2288        w1        = wqdip(1,itypi,itypj)
2289        w2        = wqdip(2,itypi,itypj)
2290        pis       = sig0head(itypi,itypj)
2291        eps_head   = epshead(itypi,itypj)
2292 c!-------------------------------------------------------------------
2293 c! R1 - distance between head of ith side chain and tail of jth sidechain
2294        R1 = 0.0d0
2295        DO k = 1, 3
2296 c! Calculate head-to-tail distances
2297         R1=R1+(ctail(k,2)-chead(k,1))**2
2298        END DO
2299 c! Pitagoras
2300        R1 = dsqrt(R1)
2301
2302 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2303 c!     &        +dhead(1,1,itypi,itypj))**2))
2304 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2305 c!     &        +dhead(2,1,itypi,itypj))**2))
2306
2307 c!-------------------------------------------------------------------
2308 c! ecl
2309        sparrow  = w1 * Qi * om1
2310        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2311        Ecl = sparrow / Rhead**2.0d0
2312      &     - hawk    / Rhead**4.0d0
2313 c!-------------------------------------------------------------------
2314 c! derivative of ecl is Gcl
2315 c! dF/dr part
2316        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2317      &           + 4.0d0 * hawk    / Rhead**5.0d0
2318 c! dF/dom1
2319        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2320 c! dF/dom2
2321        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2322 c--------------------------------------------------------------------
2323 c Polarization energy
2324 c Epol
2325        MomoFac1 = (1.0d0 - chi1 * sqom2)
2326        RR1  = R1 * R1 / MomoFac1
2327        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2328        fgb1 = sqrt( RR1 + a12sq * ee1)
2329        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2330 c!       epol = 0.0d0
2331 c!------------------------------------------------------------------
2332 c! derivative of Epol is Gpol...
2333        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2334      &          / (fgb1 ** 5.0d0)
2335        dFGBdR1 = ( (R1 / MomoFac1)
2336      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2337      &        / ( 2.0d0 * fgb1 )
2338        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2339      &          * (2.0d0 - 0.5d0 * ee1) )
2340      &          / (2.0d0 * fgb1)
2341        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2342 c!       dPOLdR1 = 0.0d0
2343        dPOLdOM1 = 0.0d0
2344        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2345 c!       dPOLdOM2 = 0.0d0
2346 c!-------------------------------------------------------------------
2347 c! Elj
2348        pom = (pis / Rhead)**6.0d0
2349        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2350 c! derivative of Elj is Glj
2351        dGLJdR = 4.0d0 * eps_head
2352      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2353      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2354 c!-------------------------------------------------------------------
2355 c! Return the results
2356        DO k = 1, 3
2357         erhead(k) = Rhead_distance(k)/Rhead
2358         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2359        END DO
2360
2361        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2362        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2363        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2364        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2365        facd1 = d1 * vbld_inv(i+nres)
2366        facd2 = d2 * vbld_inv(j+nres)
2367        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2368
2369        DO k = 1, 3
2370         hawk = (erhead_tail(k,1) +
2371      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2372
2373         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2374         gvdwx(k,i) = gvdwx(k,i)
2375      &             - dGCLdR * pom
2376      &             - dPOLdR1 * hawk
2377      &             - dGLJdR * pom
2378
2379         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2380         gvdwx(k,j) = gvdwx(k,j)
2381      &             + dGCLdR * pom
2382      &             + dPOLdR1 * (erhead_tail(k,1)
2383      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2384      &             + dGLJdR * pom
2385
2386
2387         gvdwc(k,i) = gvdwc(k,i)
2388      &             - dGCLdR * erhead(k)
2389      &             - dPOLdR1 * erhead_tail(k,1)
2390      &             - dGLJdR * erhead(k)
2391
2392         gvdwc(k,j) = gvdwc(k,j)
2393      &             + dGCLdR * erhead(k)
2394      &             + dPOLdR1 * erhead_tail(k,1)
2395      &             + dGLJdR * erhead(k)
2396
2397        END DO
2398        RETURN
2399       END SUBROUTINE eqd
2400
2401
2402 c!-------------------------------------------------------------------
2403
2404
2405       SUBROUTINE edq(Ecl,Elj,Epol)
2406        IMPLICIT NONE
2407        INCLUDE 'DIMENSIONS'
2408        INCLUDE 'DIMENSIONS.ZSCOPT'
2409        INCLUDE 'COMMON.CALC'
2410        INCLUDE 'COMMON.CHAIN'
2411        INCLUDE 'COMMON.CONTROL'
2412        INCLUDE 'COMMON.DERIV'
2413        INCLUDE 'COMMON.EMP'
2414        INCLUDE 'COMMON.GEO'
2415        INCLUDE 'COMMON.INTERACT'
2416        INCLUDE 'COMMON.IOUNITS'
2417        INCLUDE 'COMMON.LOCAL'
2418        INCLUDE 'COMMON.NAMES'
2419        INCLUDE 'COMMON.VAR'
2420        double precision scalar, facd3, adler
2421        alphapol2 = alphapol(itypj,itypi)
2422        w1        = wqdip(1,itypi,itypj)
2423        w2        = wqdip(2,itypi,itypj)
2424        pis       = sig0head(itypi,itypj)
2425        eps_head  = epshead(itypi,itypj)
2426 c!-------------------------------------------------------------------
2427 c! R2 - distance between head of jth side chain and tail of ith sidechain
2428        R2 = 0.0d0
2429        DO k = 1, 3
2430 c! Calculate head-to-tail distances
2431         R2=R2+(chead(k,2)-ctail(k,1))**2
2432        END DO
2433 c! Pitagoras
2434        R2 = dsqrt(R2)
2435
2436 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2437 c!     &        +dhead(1,1,itypi,itypj))**2))
2438 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2439 c!     &        +dhead(2,1,itypi,itypj))**2))
2440
2441
2442 c!-------------------------------------------------------------------
2443 c! ecl
2444        sparrow  = w1 * Qi * om1
2445        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2446        ECL = sparrow / Rhead**2.0d0
2447      &     - hawk    / Rhead**4.0d0
2448 c!-------------------------------------------------------------------
2449 c! derivative of ecl is Gcl
2450 c! dF/dr part
2451        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2452      &           + 4.0d0 * hawk    / Rhead**5.0d0
2453 c! dF/dom1
2454        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2455 c! dF/dom2
2456        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2457 c--------------------------------------------------------------------
2458 c Polarization energy
2459 c Epol
2460        MomoFac2 = (1.0d0 - chi2 * sqom1)
2461        RR2  = R2 * R2 / MomoFac2
2462        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2463        fgb2 = sqrt(RR2  + a12sq * ee2)
2464        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2465 c!       epol = 0.0d0
2466 c! derivative of Epol is Gpol...
2467        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2468      &          / (fgb2 ** 5.0d0)
2469        dFGBdR2 = ( (R2 / MomoFac2)
2470      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2471      &        / (2.0d0 * fgb2)
2472        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2473      &          * (2.0d0 - 0.5d0 * ee2) )
2474      &          / (2.0d0 * fgb2)
2475        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2476 c!       dPOLdR2 = 0.0d0
2477        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2478 c!       dPOLdOM1 = 0.0d0
2479        dPOLdOM2 = 0.0d0
2480 c!-------------------------------------------------------------------
2481 c! Elj
2482        pom = (pis / Rhead)**6.0d0
2483        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2484 c! derivative of Elj is Glj
2485        dGLJdR = 4.0d0 * eps_head
2486      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2487      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2488 c!-------------------------------------------------------------------
2489 c! Return the results
2490 c! (see comments in Eqq)
2491        DO k = 1, 3
2492         erhead(k) = Rhead_distance(k)/Rhead
2493         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2494        END DO
2495        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2496        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2497        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2498        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2499        facd1 = d1 * vbld_inv(i+nres)
2500        facd2 = d2 * vbld_inv(j+nres)
2501        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2502
2503        DO k = 1, 3
2504         condor = (erhead_tail(k,2)
2505      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2506
2507         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2508         gvdwx(k,i) = gvdwx(k,i)
2509      &             - dGCLdR * pom
2510      &             - dPOLdR2 * (erhead_tail(k,2)
2511      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2512      &             - dGLJdR * pom
2513
2514         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2515         gvdwx(k,j) = gvdwx(k,j)
2516      &             + dGCLdR * pom
2517      &             + dPOLdR2 * condor
2518      &             + dGLJdR * pom
2519
2520
2521         gvdwc(k,i) = gvdwc(k,i)
2522      &             - dGCLdR * erhead(k)
2523      &             - dPOLdR2 * erhead_tail(k,2)
2524      &             - dGLJdR * erhead(k)
2525
2526         gvdwc(k,j) = gvdwc(k,j)
2527      &             + dGCLdR * erhead(k)
2528      &             + dPOLdR2 * erhead_tail(k,2)
2529      &             + dGLJdR * erhead(k)
2530
2531        END DO
2532        RETURN
2533       END SUBROUTINE edq
2534
2535
2536 C--------------------------------------------------------------------
2537
2538
2539       SUBROUTINE edd(ECL)
2540        IMPLICIT NONE
2541        INCLUDE 'DIMENSIONS'
2542        INCLUDE 'DIMENSIONS.ZSCOPT'
2543        INCLUDE 'COMMON.CALC'
2544        INCLUDE 'COMMON.CHAIN'
2545        INCLUDE 'COMMON.CONTROL'
2546        INCLUDE 'COMMON.DERIV'
2547        INCLUDE 'COMMON.EMP'
2548        INCLUDE 'COMMON.GEO'
2549        INCLUDE 'COMMON.INTERACT'
2550        INCLUDE 'COMMON.IOUNITS'
2551        INCLUDE 'COMMON.LOCAL'
2552        INCLUDE 'COMMON.NAMES'
2553        INCLUDE 'COMMON.VAR'
2554        double precision scalar
2555 c!       csig = sigiso(itypi,itypj)
2556        w1 = wqdip(1,itypi,itypj)
2557        w2 = wqdip(2,itypi,itypj)
2558 c!-------------------------------------------------------------------
2559 c! ECL
2560        fac = (om12 - 3.0d0 * om1 * om2)
2561        c1 = (w1 / (Rhead**3.0d0)) * fac
2562        c2 = (w2 / Rhead ** 6.0d0)
2563      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2564        ECL = c1 - c2
2565 c!       write (*,*) "w1 = ", w1
2566 c!       write (*,*) "w2 = ", w2
2567 c!       write (*,*) "om1 = ", om1
2568 c!       write (*,*) "om2 = ", om2
2569 c!       write (*,*) "om12 = ", om12
2570 c!       write (*,*) "fac = ", fac
2571 c!       write (*,*) "c1 = ", c1
2572 c!       write (*,*) "c2 = ", c2
2573 c!       write (*,*) "Ecl = ", Ecl
2574 c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
2575 c!       write (*,*) "c2_2 = ",
2576 c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2577 c!-------------------------------------------------------------------
2578 c! dervative of ECL is GCL...
2579 c! dECL/dr
2580        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
2581        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)
2582      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
2583        dGCLdR = c1 - c2
2584 c! dECL/dom1
2585        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
2586        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2587      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
2588        dGCLdOM1 = c1 - c2
2589 c! dECL/dom2
2590        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
2591        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2592      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
2593        dGCLdOM2 = c1 - c2
2594 c! dECL/dom12
2595        c1 = w1 / (Rhead ** 3.0d0)
2596        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
2597        dGCLdOM12 = c1 - c2
2598 c!-------------------------------------------------------------------
2599 c! Return the results
2600 c! (see comments in Eqq)
2601        DO k= 1, 3
2602         erhead(k) = Rhead_distance(k)/Rhead
2603        END DO
2604        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2605        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2606        facd1 = d1 * vbld_inv(i+nres)
2607        facd2 = d2 * vbld_inv(j+nres)
2608        DO k = 1, 3
2609
2610         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2611         gvdwx(k,i) = gvdwx(k,i)
2612      &             - dGCLdR * pom
2613         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2614         gvdwx(k,j) = gvdwx(k,j)
2615      &             + dGCLdR * pom
2616
2617         gvdwc(k,i) = gvdwc(k,i)
2618      &             - dGCLdR * erhead(k)
2619         gvdwc(k,j) = gvdwc(k,j)
2620      &             + dGCLdR * erhead(k)
2621        END DO
2622        RETURN
2623       END SUBROUTINE edd
2624
2625
2626 c!-------------------------------------------------------------------
2627
2628
2629       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
2630        IMPLICIT NONE
2631 c! maxres
2632        INCLUDE 'DIMENSIONS'
2633 c! itypi, itypj, i, j, k, l, chead,
2634        INCLUDE 'COMMON.CALC'
2635 c! c, nres, dc_norm
2636        INCLUDE 'COMMON.CHAIN'
2637 c! gradc, gradx
2638        INCLUDE 'COMMON.DERIV'
2639 c! electrostatic gradients-specific variables
2640        INCLUDE 'COMMON.EMP'
2641 c! wquad, dhead, alphiso, alphasur, rborn, epsintab
2642        INCLUDE 'COMMON.INTERACT'
2643 c! io for debug, disable it in final builds
2644        INCLUDE 'COMMON.IOUNITS'
2645 c!-------------------------------------------------------------------
2646 c! Variable Init
2647
2648 c! what amino acid is the aminoacid j'th?
2649        itypj = itype(j)
2650 c! 1/(Gas Constant * Thermostate temperature) = BetaT
2651 c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
2652        BetaT = 1.0d0 / (298 * 1.987d-3)
2653 c! Gay-berne var's
2654        sig0ij = sigma( itypi,itypj )
2655        chi1   = chi( itypi, itypj )
2656        chi2   = chi( itypj, itypi )
2657        chi12  = chi1 * chi2
2658        chip1  = chipp( itypi, itypj )
2659        chip2  = chipp( itypj, itypi )
2660        chip12 = chip1 * chip2
2661 c!       write (2,*) "elgrad types",itypi,itypj,
2662 c!     & " chi1",chi1," chi2",chi2," chi12",chi12,
2663 c!     &  " chip1",chip1," chip2",chip2," chip12",chip12
2664 c! not used by momo potential, but needed by sc_angular which is shared
2665 c! by all energy_potential subroutines
2666        alf1   = 0.0d0
2667        alf2   = 0.0d0
2668        alf12  = 0.0d0
2669 c! location, location, location
2670        xj  = c( 1, nres+j ) - xi
2671        yj  = c( 2, nres+j ) - yi
2672        zj  = c( 3, nres+j ) - zi
2673        dxj = dc_norm( 1, nres+j )
2674        dyj = dc_norm( 2, nres+j )
2675        dzj = dc_norm( 3, nres+j )
2676 c! distance from center of chain(?) to polar/charged head
2677 c!       write (*,*) "istate = ", 1
2678 c!       write (*,*) "ii = ", 1
2679 c!       write (*,*) "jj = ", 1
2680        d1 = dhead(1, 1, itypi, itypj)
2681        d2 = dhead(2, 1, itypi, itypj)
2682 c! ai*aj from Fgb
2683        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
2684 c!       a12sq = a12sq * a12sq
2685 c! charge of amino acid itypi is...
2686        Qi  = icharge(itypi)
2687        Qj  = icharge(itypj)
2688        Qij = Qi * Qj
2689 c! chis1,2,12
2690        chis1 = chis(itypi,itypj)
2691        chis2 = chis(itypj,itypi)
2692        chis12 = chis1 * chis2
2693        sig1 = sigmap1(itypi,itypj)
2694        sig2 = sigmap2(itypi,itypj)
2695 c!       write (*,*) "sig1 = ", sig1
2696 c!       write (*,*) "sig2 = ", sig2
2697 c! alpha factors from Fcav/Gcav
2698        b1 = alphasur(1,itypi,itypj)
2699        b2 = alphasur(2,itypi,itypj)
2700        b3 = alphasur(3,itypi,itypj)
2701        b4 = alphasur(4,itypi,itypj)
2702 c! used to determine whether we want to do quadrupole calculations
2703        wqd = wquad(itypi, itypj)
2704 c! used by Fgb
2705        eps_in = epsintab(itypi,itypj)
2706        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
2707 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
2708 c!-------------------------------------------------------------------
2709 c! tail location and distance calculations
2710        Rtail = 0.0d0
2711        DO k = 1, 3
2712         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
2713         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
2714        END DO
2715 c! tail distances will be themselves usefull elswhere
2716 c1 (in Gcav, for example)
2717        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
2718        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
2719        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
2720        Rtail = dsqrt(
2721      &     (Rtail_distance(1)*Rtail_distance(1))
2722      &   + (Rtail_distance(2)*Rtail_distance(2))
2723      &   + (Rtail_distance(3)*Rtail_distance(3)))
2724 c!-------------------------------------------------------------------
2725 c! Calculate location and distance between polar heads
2726 c! distance between heads
2727 c! for each one of our three dimensional space...
2728        DO k = 1,3
2729 c! location of polar head is computed by taking hydrophobic centre
2730 c! and moving by a d1 * dc_norm vector
2731 c! see unres publications for very informative images
2732         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
2733         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
2734 c! distance
2735 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
2736 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
2737         Rhead_distance(k) = chead(k,2) - chead(k,1)
2738        END DO
2739 c! pitagoras (root of sum of squares)
2740        Rhead = dsqrt(
2741      &     (Rhead_distance(1)*Rhead_distance(1))
2742      &   + (Rhead_distance(2)*Rhead_distance(2))
2743      &   + (Rhead_distance(3)*Rhead_distance(3)))
2744 c!-------------------------------------------------------------------
2745 c! zero everything that should be zero'ed
2746        Egb = 0.0d0
2747        ECL = 0.0d0
2748        Elj = 0.0d0
2749        Equad = 0.0d0
2750        Epol = 0.0d0
2751        eheadtail = 0.0d0
2752        dGCLdOM1 = 0.0d0
2753        dGCLdOM2 = 0.0d0
2754        dGCLdOM12 = 0.0d0
2755        dPOLdOM1 = 0.0d0
2756        dPOLdOM2 = 0.0d0
2757        RETURN
2758       END SUBROUTINE elgrad_init
2759 c!-------------------------------------------------------------------
2760       subroutine sc_angular
2761 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2762 C om12. Called by ebp, egb, and egbv.
2763       implicit none
2764       include 'COMMON.CALC'
2765       include 'COMMON.IOUNITS'
2766       erij(1)=xj*rij
2767       erij(2)=yj*rij
2768       erij(3)=zj*rij
2769       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2770       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2771       om12=dxi*dxj+dyi*dyj+dzi*dzj
2772 c!      om1    = 0.0d0
2773 c!      om2    = 0.0d0
2774 c!      om12   = 0.0d0
2775       chiom12=chi12*om12
2776 C Calculate eps1(om12) and its derivative in om12
2777       faceps1=1.0D0-om12*chiom12
2778       faceps1_inv=1.0D0/faceps1
2779       eps1=dsqrt(faceps1_inv)
2780 c      write (2,*) "chi1",chi1," chi2",chi2," chi12",chi12
2781 c      write (2,*) "fsceps1",faceps1," faceps1_inv",faceps1_inv,
2782 c     & " eps1",eps1
2783 C Following variable is eps1*deps1/dom12
2784       eps1_om12=faceps1_inv*chiom12
2785 c diagnostics only
2786 c      faceps1_inv=om12
2787 c      eps1=om12
2788 c      eps1_om12=1.0d0
2789 c      write (iout,*) "om12",om12," eps1",eps1
2790 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2791 C and om12.
2792       om1om2=om1*om2
2793       chiom1=chi1*om1
2794       chiom2=chi2*om2
2795       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2796       sigsq=1.0D0-facsig*faceps1_inv
2797 c      write (2,*) "om1",om1," om2",om2," om1om2",om1om2,
2798 c     & " chiom1",chiom1,
2799 c     &  " chiom2",chiom2," facsig",facsig," sigsq",sigsq
2800       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2801       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2802       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2803 c diagnostics only
2804 c      sigsq=1.0d0
2805 c      sigsq_om1=0.0d0
2806 c      sigsq_om2=0.0d0
2807 c      sigsq_om12=0.0d0
2808 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2809 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2810 c     &    " eps1",eps1
2811 C Calculate eps2 and its derivatives in om1, om2, and om12.
2812       chipom1=chip1*om1
2813       chipom2=chip2*om2
2814       chipom12=chip12*om12
2815       facp=1.0D0-om12*chipom12
2816       facp_inv=1.0D0/facp
2817       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2818 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2819 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2820 C Following variable is the square root of eps2
2821       eps2rt=1.0D0-facp1*facp_inv
2822 C Following three variables are the derivatives of the square root of eps
2823 C in om1, om2, and om12.
2824       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2825       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2826       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2827 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2828 c! Note that THIS is 0 in emomo, so we should probably move it out of sc_angular
2829 c! Or frankly, we should restructurize the whole energy section
2830       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2831 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2832 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2833 c     &  " eps2rt_om12",eps2rt_om12
2834 C Calculate whole angle-dependent part of epsilon and contributions
2835 C to its derivatives
2836       return
2837       end
2838 C----------------------------------------------------------------------------
2839       subroutine sc_grad
2840       implicit real*8 (a-h,o-z)
2841       include 'DIMENSIONS'
2842       include 'DIMENSIONS.ZSCOPT'
2843       include 'COMMON.CHAIN'
2844       include 'COMMON.DERIV'
2845       include 'COMMON.CALC'
2846       double precision dcosom1(3),dcosom2(3)
2847       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2848       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2849       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2850      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2851       do k=1,3
2852         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2853         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2854       enddo
2855       do k=1,3
2856         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2857       enddo
2858       do k=1,3
2859         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2860      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2861      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2862         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2863      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2864      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2865       enddo
2866 C
2867 C Calculate the components of the gradient in DC and X
2868 C
2869       do k=i,j-1
2870         do l=1,3
2871           gvdwc(l,k)=gvdwc(l,k)+gg(l)
2872         enddo
2873       enddo
2874       return
2875       end
2876 c------------------------------------------------------------------------------
2877       subroutine vec_and_deriv
2878       implicit real*8 (a-h,o-z)
2879       include 'DIMENSIONS'
2880       include 'DIMENSIONS.ZSCOPT'
2881       include 'COMMON.IOUNITS'
2882       include 'COMMON.GEO'
2883       include 'COMMON.VAR'
2884       include 'COMMON.LOCAL'
2885       include 'COMMON.CHAIN'
2886       include 'COMMON.VECTORS'
2887       include 'COMMON.DERIV'
2888       include 'COMMON.INTERACT'
2889       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2890 C Compute the local reference systems. For reference system (i), the
2891 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2892 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2893       do i=1,nres-1
2894 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
2895           if (i.eq.nres-1) then
2896 C Case of the last full residue
2897 C Compute the Z-axis
2898             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2899             costh=dcos(pi-theta(nres))
2900             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2901             do k=1,3
2902               uz(k,i)=fac*uz(k,i)
2903             enddo
2904             if (calc_grad) then
2905 C Compute the derivatives of uz
2906             uzder(1,1,1)= 0.0d0
2907             uzder(2,1,1)=-dc_norm(3,i-1)
2908             uzder(3,1,1)= dc_norm(2,i-1)
2909             uzder(1,2,1)= dc_norm(3,i-1)
2910             uzder(2,2,1)= 0.0d0
2911             uzder(3,2,1)=-dc_norm(1,i-1)
2912             uzder(1,3,1)=-dc_norm(2,i-1)
2913             uzder(2,3,1)= dc_norm(1,i-1)
2914             uzder(3,3,1)= 0.0d0
2915             uzder(1,1,2)= 0.0d0
2916             uzder(2,1,2)= dc_norm(3,i)
2917             uzder(3,1,2)=-dc_norm(2,i)
2918             uzder(1,2,2)=-dc_norm(3,i)
2919             uzder(2,2,2)= 0.0d0
2920             uzder(3,2,2)= dc_norm(1,i)
2921             uzder(1,3,2)= dc_norm(2,i)
2922             uzder(2,3,2)=-dc_norm(1,i)
2923             uzder(3,3,2)= 0.0d0
2924             endif
2925 C Compute the Y-axis
2926             facy=fac
2927             do k=1,3
2928               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2929             enddo
2930             if (calc_grad) then
2931 C Compute the derivatives of uy
2932             do j=1,3
2933               do k=1,3
2934                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2935      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2936                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2937               enddo
2938               uyder(j,j,1)=uyder(j,j,1)-costh
2939               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2940             enddo
2941             do j=1,2
2942               do k=1,3
2943                 do l=1,3
2944                   uygrad(l,k,j,i)=uyder(l,k,j)
2945                   uzgrad(l,k,j,i)=uzder(l,k,j)
2946                 enddo
2947               enddo
2948             enddo
2949             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2950             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2951             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2952             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2953             endif
2954           else
2955 C Other residues
2956 C Compute the Z-axis
2957             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2958             costh=dcos(pi-theta(i+2))
2959             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2960             do k=1,3
2961               uz(k,i)=fac*uz(k,i)
2962             enddo
2963             if (calc_grad) then
2964 C Compute the derivatives of uz
2965             uzder(1,1,1)= 0.0d0
2966             uzder(2,1,1)=-dc_norm(3,i+1)
2967             uzder(3,1,1)= dc_norm(2,i+1)
2968             uzder(1,2,1)= dc_norm(3,i+1)
2969             uzder(2,2,1)= 0.0d0
2970             uzder(3,2,1)=-dc_norm(1,i+1)
2971             uzder(1,3,1)=-dc_norm(2,i+1)
2972             uzder(2,3,1)= dc_norm(1,i+1)
2973             uzder(3,3,1)= 0.0d0
2974             uzder(1,1,2)= 0.0d0
2975             uzder(2,1,2)= dc_norm(3,i)
2976             uzder(3,1,2)=-dc_norm(2,i)
2977             uzder(1,2,2)=-dc_norm(3,i)
2978             uzder(2,2,2)= 0.0d0
2979             uzder(3,2,2)= dc_norm(1,i)
2980             uzder(1,3,2)= dc_norm(2,i)
2981             uzder(2,3,2)=-dc_norm(1,i)
2982             uzder(3,3,2)= 0.0d0
2983             endif
2984 C Compute the Y-axis
2985             facy=fac
2986             do k=1,3
2987               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2988             enddo
2989             if (calc_grad) then
2990 C Compute the derivatives of uy
2991             do j=1,3
2992               do k=1,3
2993                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2994      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2995                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2996               enddo
2997               uyder(j,j,1)=uyder(j,j,1)-costh
2998               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2999             enddo
3000             do j=1,2
3001               do k=1,3
3002                 do l=1,3
3003                   uygrad(l,k,j,i)=uyder(l,k,j)
3004                   uzgrad(l,k,j,i)=uzder(l,k,j)
3005                 enddo
3006               enddo
3007             enddo
3008             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3009             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3010             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3011             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3012           endif
3013           endif
3014       enddo
3015       if (calc_grad) then
3016       do i=1,nres-1
3017         vbld_inv_temp(1)=vbld_inv(i+1)
3018         if (i.lt.nres-1) then
3019           vbld_inv_temp(2)=vbld_inv(i+2)
3020         else
3021           vbld_inv_temp(2)=vbld_inv(i)
3022         endif
3023         do j=1,2
3024           do k=1,3
3025             do l=1,3
3026               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
3027               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
3028             enddo
3029           enddo
3030         enddo
3031       enddo
3032       endif
3033       return
3034       end
3035 C-----------------------------------------------------------------------------
3036       subroutine vec_and_deriv_test
3037       implicit real*8 (a-h,o-z)
3038       include 'DIMENSIONS'
3039       include 'DIMENSIONS.ZSCOPT'
3040       include 'COMMON.IOUNITS'
3041       include 'COMMON.GEO'
3042       include 'COMMON.VAR'
3043       include 'COMMON.LOCAL'
3044       include 'COMMON.CHAIN'
3045       include 'COMMON.VECTORS'
3046       dimension uyder(3,3,2),uzder(3,3,2)
3047 C Compute the local reference systems. For reference system (i), the
3048 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
3049 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
3050       do i=1,nres-1
3051           if (i.eq.nres-1) then
3052 C Case of the last full residue
3053 C Compute the Z-axis
3054             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
3055             costh=dcos(pi-theta(nres))
3056             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3057 c            write (iout,*) 'fac',fac,
3058 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3059             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3060             do k=1,3
3061               uz(k,i)=fac*uz(k,i)
3062             enddo
3063 C Compute the derivatives of uz
3064             uzder(1,1,1)= 0.0d0
3065             uzder(2,1,1)=-dc_norm(3,i-1)
3066             uzder(3,1,1)= dc_norm(2,i-1)
3067             uzder(1,2,1)= dc_norm(3,i-1)
3068             uzder(2,2,1)= 0.0d0
3069             uzder(3,2,1)=-dc_norm(1,i-1)
3070             uzder(1,3,1)=-dc_norm(2,i-1)
3071             uzder(2,3,1)= dc_norm(1,i-1)
3072             uzder(3,3,1)= 0.0d0
3073             uzder(1,1,2)= 0.0d0
3074             uzder(2,1,2)= dc_norm(3,i)
3075             uzder(3,1,2)=-dc_norm(2,i)
3076             uzder(1,2,2)=-dc_norm(3,i)
3077             uzder(2,2,2)= 0.0d0
3078             uzder(3,2,2)= dc_norm(1,i)
3079             uzder(1,3,2)= dc_norm(2,i)
3080             uzder(2,3,2)=-dc_norm(1,i)
3081             uzder(3,3,2)= 0.0d0
3082 C Compute the Y-axis
3083             do k=1,3
3084               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
3085             enddo
3086             facy=fac
3087             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
3088      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
3089      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
3090             do k=1,3
3091 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3092               uy(k,i)=
3093 c     &        facy*(
3094      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
3095      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
3096 c     &        )
3097             enddo
3098 c            write (iout,*) 'facy',facy,
3099 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3100             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3101             do k=1,3
3102               uy(k,i)=facy*uy(k,i)
3103             enddo
3104 C Compute the derivatives of uy
3105             do j=1,3
3106               do k=1,3
3107                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
3108      &                        -dc_norm(k,i)*dc_norm(j,i-1)
3109                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3110               enddo
3111 c              uyder(j,j,1)=uyder(j,j,1)-costh
3112 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
3113               uyder(j,j,1)=uyder(j,j,1)
3114      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
3115               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
3116      &          +uyder(j,j,2)
3117             enddo
3118             do j=1,2
3119               do k=1,3
3120                 do l=1,3
3121                   uygrad(l,k,j,i)=uyder(l,k,j)
3122                   uzgrad(l,k,j,i)=uzder(l,k,j)
3123                 enddo
3124               enddo
3125             enddo
3126             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3127             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3128             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3129             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3130           else
3131 C Other residues
3132 C Compute the Z-axis
3133             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
3134             costh=dcos(pi-theta(i+2))
3135             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3136             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3137             do k=1,3
3138               uz(k,i)=fac*uz(k,i)
3139             enddo
3140 C Compute the derivatives of uz
3141             uzder(1,1,1)= 0.0d0
3142             uzder(2,1,1)=-dc_norm(3,i+1)
3143             uzder(3,1,1)= dc_norm(2,i+1)
3144             uzder(1,2,1)= dc_norm(3,i+1)
3145             uzder(2,2,1)= 0.0d0
3146             uzder(3,2,1)=-dc_norm(1,i+1)
3147             uzder(1,3,1)=-dc_norm(2,i+1)
3148             uzder(2,3,1)= dc_norm(1,i+1)
3149             uzder(3,3,1)= 0.0d0
3150             uzder(1,1,2)= 0.0d0
3151             uzder(2,1,2)= dc_norm(3,i)
3152             uzder(3,1,2)=-dc_norm(2,i)
3153             uzder(1,2,2)=-dc_norm(3,i)
3154             uzder(2,2,2)= 0.0d0
3155             uzder(3,2,2)= dc_norm(1,i)
3156             uzder(1,3,2)= dc_norm(2,i)
3157             uzder(2,3,2)=-dc_norm(1,i)
3158             uzder(3,3,2)= 0.0d0
3159 C Compute the Y-axis
3160             facy=fac
3161             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
3162      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
3163      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
3164             do k=1,3
3165 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3166               uy(k,i)=
3167 c     &        facy*(
3168      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
3169      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
3170 c     &        )
3171             enddo
3172 c            write (iout,*) 'facy',facy,
3173 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3174             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3175             do k=1,3
3176               uy(k,i)=facy*uy(k,i)
3177             enddo
3178 C Compute the derivatives of uy
3179             do j=1,3
3180               do k=1,3
3181                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
3182      &                        -dc_norm(k,i)*dc_norm(j,i+1)
3183                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3184               enddo
3185 c              uyder(j,j,1)=uyder(j,j,1)-costh
3186 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
3187               uyder(j,j,1)=uyder(j,j,1)
3188      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
3189               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
3190      &          +uyder(j,j,2)
3191             enddo
3192             do j=1,2
3193               do k=1,3
3194                 do l=1,3
3195                   uygrad(l,k,j,i)=uyder(l,k,j)
3196                   uzgrad(l,k,j,i)=uzder(l,k,j)
3197                 enddo
3198               enddo
3199             enddo
3200             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3201             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3202             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3203             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3204           endif
3205       enddo
3206       do i=1,nres-1
3207         do j=1,2
3208           do k=1,3
3209             do l=1,3
3210               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
3211               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
3212             enddo
3213           enddo
3214         enddo
3215       enddo
3216       return
3217       end
3218 C-----------------------------------------------------------------------------
3219       subroutine check_vecgrad
3220       implicit real*8 (a-h,o-z)
3221       include 'DIMENSIONS'
3222       include 'DIMENSIONS.ZSCOPT'
3223       include 'COMMON.IOUNITS'
3224       include 'COMMON.GEO'
3225       include 'COMMON.VAR'
3226       include 'COMMON.LOCAL'
3227       include 'COMMON.CHAIN'
3228       include 'COMMON.VECTORS'
3229       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
3230       dimension uyt(3,maxres),uzt(3,maxres)
3231       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
3232       double precision delta /1.0d-7/
3233       call vec_and_deriv
3234 cd      do i=1,nres
3235 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
3236 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
3237 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
3238 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
3239 cd     &     (dc_norm(if90,i),if90=1,3)
3240 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
3241 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
3242 cd          write(iout,'(a)')
3243 cd      enddo
3244       do i=1,nres
3245         do j=1,2
3246           do k=1,3
3247             do l=1,3
3248               uygradt(l,k,j,i)=uygrad(l,k,j,i)
3249               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
3250             enddo
3251           enddo
3252         enddo
3253       enddo
3254       call vec_and_deriv
3255       do i=1,nres
3256         do j=1,3
3257           uyt(j,i)=uy(j,i)
3258           uzt(j,i)=uz(j,i)
3259         enddo
3260       enddo
3261       do i=1,nres
3262 cd        write (iout,*) 'i=',i
3263         do k=1,3
3264           erij(k)=dc_norm(k,i)
3265         enddo
3266         do j=1,3
3267           do k=1,3
3268             dc_norm(k,i)=erij(k)
3269           enddo
3270           dc_norm(j,i)=dc_norm(j,i)+delta
3271 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
3272 c          do k=1,3
3273 c            dc_norm(k,i)=dc_norm(k,i)/fac
3274 c          enddo
3275 c          write (iout,*) (dc_norm(k,i),k=1,3)
3276 c          write (iout,*) (erij(k),k=1,3)
3277           call vec_and_deriv
3278           do k=1,3
3279             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
3280             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
3281             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
3282             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
3283           enddo
3284 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3285 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
3286 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
3287         enddo
3288         do k=1,3
3289           dc_norm(k,i)=erij(k)
3290         enddo
3291 cd        do k=1,3
3292 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3293 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
3294 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
3295 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3296 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
3297 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
3298 cd          write (iout,'(a)')
3299 cd        enddo
3300       enddo
3301       return
3302       end
3303 C--------------------------------------------------------------------------
3304       subroutine set_matrices
3305       implicit real*8 (a-h,o-z)
3306       include 'DIMENSIONS'
3307       include 'DIMENSIONS.ZSCOPT'
3308       include 'COMMON.IOUNITS'
3309       include 'COMMON.GEO'
3310       include 'COMMON.VAR'
3311       include 'COMMON.LOCAL'
3312       include 'COMMON.CHAIN'
3313       include 'COMMON.DERIV'
3314       include 'COMMON.INTERACT'
3315       include 'COMMON.CONTACTS'
3316       include 'COMMON.TORSION'
3317       include 'COMMON.VECTORS'
3318       include 'COMMON.FFIELD'
3319       double precision auxvec(2),auxmat(2,2)
3320 C
3321 C Compute the virtual-bond-torsional-angle dependent quantities needed
3322 C to calculate the el-loc multibody terms of various order.
3323 C
3324       do i=3,nres+1
3325         if (i .lt. nres+1) then
3326           sin1=dsin(phi(i))
3327           cos1=dcos(phi(i))
3328           sintab(i-2)=sin1
3329           costab(i-2)=cos1
3330           obrot(1,i-2)=cos1
3331           obrot(2,i-2)=sin1
3332           sin2=dsin(2*phi(i))
3333           cos2=dcos(2*phi(i))
3334           sintab2(i-2)=sin2
3335           costab2(i-2)=cos2
3336           obrot2(1,i-2)=cos2
3337           obrot2(2,i-2)=sin2
3338           Ug(1,1,i-2)=-cos1
3339           Ug(1,2,i-2)=-sin1
3340           Ug(2,1,i-2)=-sin1
3341           Ug(2,2,i-2)= cos1
3342           Ug2(1,1,i-2)=-cos2
3343           Ug2(1,2,i-2)=-sin2
3344           Ug2(2,1,i-2)=-sin2
3345           Ug2(2,2,i-2)= cos2
3346         else
3347           costab(i-2)=1.0d0
3348           sintab(i-2)=0.0d0
3349           obrot(1,i-2)=1.0d0
3350           obrot(2,i-2)=0.0d0
3351           obrot2(1,i-2)=0.0d0
3352           obrot2(2,i-2)=0.0d0
3353           Ug(1,1,i-2)=1.0d0
3354           Ug(1,2,i-2)=0.0d0
3355           Ug(2,1,i-2)=0.0d0
3356           Ug(2,2,i-2)=1.0d0
3357           Ug2(1,1,i-2)=0.0d0
3358           Ug2(1,2,i-2)=0.0d0
3359           Ug2(2,1,i-2)=0.0d0
3360           Ug2(2,2,i-2)=0.0d0
3361         endif
3362         if (i .gt. 3 .and. i .lt. nres+1) then
3363           obrot_der(1,i-2)=-sin1
3364           obrot_der(2,i-2)= cos1
3365           Ugder(1,1,i-2)= sin1
3366           Ugder(1,2,i-2)=-cos1
3367           Ugder(2,1,i-2)=-cos1
3368           Ugder(2,2,i-2)=-sin1
3369           dwacos2=cos2+cos2
3370           dwasin2=sin2+sin2
3371           obrot2_der(1,i-2)=-dwasin2
3372           obrot2_der(2,i-2)= dwacos2
3373           Ug2der(1,1,i-2)= dwasin2
3374           Ug2der(1,2,i-2)=-dwacos2
3375           Ug2der(2,1,i-2)=-dwacos2
3376           Ug2der(2,2,i-2)=-dwasin2
3377         else
3378           obrot_der(1,i-2)=0.0d0
3379           obrot_der(2,i-2)=0.0d0
3380           Ugder(1,1,i-2)=0.0d0
3381           Ugder(1,2,i-2)=0.0d0
3382           Ugder(2,1,i-2)=0.0d0
3383           Ugder(2,2,i-2)=0.0d0
3384           obrot2_der(1,i-2)=0.0d0
3385           obrot2_der(2,i-2)=0.0d0
3386           Ug2der(1,1,i-2)=0.0d0
3387           Ug2der(1,2,i-2)=0.0d0
3388           Ug2der(2,1,i-2)=0.0d0
3389           Ug2der(2,2,i-2)=0.0d0
3390         endif
3391         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3392           iti = itortyp(itype(i-2))
3393         else
3394           iti=ntortyp+1
3395         endif
3396         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3397           iti1 = itortyp(itype(i-1))
3398         else
3399           iti1=ntortyp+1
3400         endif
3401 cd        write (iout,*) '*******i',i,' iti1',iti
3402 cd        write (iout,*) 'b1',b1(:,iti)
3403 cd        write (iout,*) 'b2',b2(:,iti)
3404 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3405         if (i .gt. iatel_s+2) then
3406           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
3407           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
3408           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3409           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3410           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3411           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3412           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3413         else
3414           do k=1,2
3415             Ub2(k,i-2)=0.0d0
3416             Ctobr(k,i-2)=0.0d0
3417             Dtobr2(k,i-2)=0.0d0
3418             do l=1,2
3419               EUg(l,k,i-2)=0.0d0
3420               CUg(l,k,i-2)=0.0d0
3421               DUg(l,k,i-2)=0.0d0
3422               DtUg2(l,k,i-2)=0.0d0
3423             enddo
3424           enddo
3425         endif
3426         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
3427         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
3428         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3429         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3430         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3431         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3432         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3433         do k=1,2
3434           muder(k,i-2)=Ub2der(k,i-2)
3435         enddo
3436         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3437           iti1 = itortyp(itype(i-1))
3438         else
3439           iti1=ntortyp+1
3440         endif
3441         do k=1,2
3442           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
3443         enddo
3444 C Vectors and matrices dependent on a single virtual-bond dihedral.
3445         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
3446         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3447         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3448         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3449         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3450         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3451         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3452         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3453         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3454 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
3455 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
3456       enddo
3457 C Matrices dependent on two consecutive virtual-bond dihedrals.
3458 C The order of matrices is from left to right.
3459       do i=2,nres-1
3460         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3461         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3462         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3463         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3464         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3465         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3466         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3467         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3468       enddo
3469 cd      do i=1,nres
3470 cd        iti = itortyp(itype(i))
3471 cd        write (iout,*) i
3472 cd        do j=1,2
3473 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3474 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3475 cd        enddo
3476 cd      enddo
3477       return
3478       end
3479 C--------------------------------------------------------------------------
3480       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3481 C
3482 C This subroutine calculates the average interaction energy and its gradient
3483 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3484 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3485 C The potential depends both on the distance of peptide-group centers and on
3486 C the orientation of the CA-CA virtual bonds.
3487 C
3488       implicit real*8 (a-h,o-z)
3489       include 'DIMENSIONS'
3490       include 'DIMENSIONS.ZSCOPT'
3491       include 'COMMON.CONTROL'
3492       include 'COMMON.IOUNITS'
3493       include 'COMMON.GEO'
3494       include 'COMMON.VAR'
3495       include 'COMMON.LOCAL'
3496       include 'COMMON.CHAIN'
3497       include 'COMMON.DERIV'
3498       include 'COMMON.INTERACT'
3499       include 'COMMON.CONTACTS'
3500       include 'COMMON.TORSION'
3501       include 'COMMON.VECTORS'
3502       include 'COMMON.FFIELD'
3503       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3504      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3505       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3506      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3507       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
3508 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3509       double precision scal_el /0.5d0/
3510 C 12/13/98
3511 C 13-go grudnia roku pamietnego...
3512       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3513      &                   0.0d0,1.0d0,0.0d0,
3514      &                   0.0d0,0.0d0,1.0d0/
3515 cd      write(iout,*) 'In EELEC'
3516 cd      do i=1,nloctyp
3517 cd        write(iout,*) 'Type',i
3518 cd        write(iout,*) 'B1',B1(:,i)
3519 cd        write(iout,*) 'B2',B2(:,i)
3520 cd        write(iout,*) 'CC',CC(:,:,i)
3521 cd        write(iout,*) 'DD',DD(:,:,i)
3522 cd        write(iout,*) 'EE',EE(:,:,i)
3523 cd      enddo
3524 cd      call check_vecgrad
3525 cd      stop
3526       if (icheckgrad.eq.1) then
3527         do i=1,nres-1
3528           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3529           do k=1,3
3530             dc_norm(k,i)=dc(k,i)*fac
3531           enddo
3532 c          write (iout,*) 'i',i,' fac',fac
3533         enddo
3534       endif
3535       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3536      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3537      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3538 cd      if (wel_loc.gt.0.0d0) then
3539         if (icheckgrad.eq.1) then
3540         call vec_and_deriv_test
3541         else
3542         call vec_and_deriv
3543         endif
3544         call set_matrices
3545       endif
3546 cd      do i=1,nres-1
3547 cd        write (iout,*) 'i=',i
3548 cd        do k=1,3
3549 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3550 cd        enddo
3551 cd        do k=1,3
3552 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3553 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3554 cd        enddo
3555 cd      enddo
3556       num_conti_hb=0
3557       ees=0.0D0
3558       evdw1=0.0D0
3559       eel_loc=0.0d0
3560       eello_turn3=0.0d0
3561       eello_turn4=0.0d0
3562       ind=0
3563       do i=1,nres
3564         num_cont_hb(i)=0
3565       enddo
3566 cd      print '(a)','Enter EELEC'
3567 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3568       do i=1,nres
3569         gel_loc_loc(i)=0.0d0
3570         gcorr_loc(i)=0.0d0
3571       enddo
3572       do i=iatel_s,iatel_e
3573         if (itel(i).eq.0) goto 1215
3574         dxi=dc(1,i)
3575         dyi=dc(2,i)
3576         dzi=dc(3,i)
3577         dx_normi=dc_norm(1,i)
3578         dy_normi=dc_norm(2,i)
3579         dz_normi=dc_norm(3,i)
3580         xmedi=c(1,i)+0.5d0*dxi
3581         ymedi=c(2,i)+0.5d0*dyi
3582         zmedi=c(3,i)+0.5d0*dzi
3583         num_conti=0
3584 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3585         do j=ielstart(i),ielend(i)
3586           if (itel(j).eq.0) goto 1216
3587           ind=ind+1
3588           iteli=itel(i)
3589           itelj=itel(j)
3590           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3591           aaa=app(iteli,itelj)
3592           bbb=bpp(iteli,itelj)
3593 C Diagnostics only!!!
3594 c         aaa=0.0D0
3595 c         bbb=0.0D0
3596 c         ael6i=0.0D0
3597 c         ael3i=0.0D0
3598 C End diagnostics
3599           ael6i=ael6(iteli,itelj)
3600           ael3i=ael3(iteli,itelj)
3601           dxj=dc(1,j)
3602           dyj=dc(2,j)
3603           dzj=dc(3,j)
3604           dx_normj=dc_norm(1,j)
3605           dy_normj=dc_norm(2,j)
3606           dz_normj=dc_norm(3,j)
3607           xj=c(1,j)+0.5D0*dxj-xmedi
3608           yj=c(2,j)+0.5D0*dyj-ymedi
3609           zj=c(3,j)+0.5D0*dzj-zmedi
3610           rij=xj*xj+yj*yj+zj*zj
3611           rrmij=1.0D0/rij
3612           rij=dsqrt(rij)
3613           rmij=1.0D0/rij
3614           r3ij=rrmij*rmij
3615           r6ij=r3ij*r3ij
3616           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3617           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3618           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3619           fac=cosa-3.0D0*cosb*cosg
3620           ev1=aaa*r6ij*r6ij
3621 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3622           if (j.eq.i+2) ev1=scal_el*ev1
3623           ev2=bbb*r6ij
3624           fac3=ael6i*r6ij
3625           fac4=ael3i*r3ij
3626           evdwij=ev1+ev2
3627           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3628           el2=fac4*fac
3629           eesij=el1+el2
3630 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
3631 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3632           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3633           ees=ees+eesij
3634           evdw1=evdw1+evdwij
3635 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3636 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3637 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3638 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3639 C
3640 C Calculate contributions to the Cartesian gradient.
3641 C
3642 #ifdef SPLITELE
3643           facvdw=-6*rrmij*(ev1+evdwij)
3644           facel=-3*rrmij*(el1+eesij)
3645           fac1=fac
3646           erij(1)=xj*rmij
3647           erij(2)=yj*rmij
3648           erij(3)=zj*rmij
3649           if (calc_grad) then
3650 *
3651 * Radial derivatives. First process both termini of the fragment (i,j)
3652 *
3653           ggg(1)=facel*xj
3654           ggg(2)=facel*yj
3655           ggg(3)=facel*zj
3656           do k=1,3
3657             ghalf=0.5D0*ggg(k)
3658             gelc(k,i)=gelc(k,i)+ghalf
3659             gelc(k,j)=gelc(k,j)+ghalf
3660           enddo
3661 *
3662 * Loop over residues i+1 thru j-1.
3663 *
3664           do k=i+1,j-1
3665             do l=1,3
3666               gelc(l,k)=gelc(l,k)+ggg(l)
3667             enddo
3668           enddo
3669           ggg(1)=facvdw*xj
3670           ggg(2)=facvdw*yj
3671           ggg(3)=facvdw*zj
3672           do k=1,3
3673             ghalf=0.5D0*ggg(k)
3674             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3675             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3676           enddo
3677 *
3678 * Loop over residues i+1 thru j-1.
3679 *
3680           do k=i+1,j-1
3681             do l=1,3
3682               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3683             enddo
3684           enddo
3685 #else
3686           facvdw=ev1+evdwij
3687           facel=el1+eesij
3688           fac1=fac
3689           fac=-3*rrmij*(facvdw+facvdw+facel)
3690           erij(1)=xj*rmij
3691           erij(2)=yj*rmij
3692           erij(3)=zj*rmij
3693           if (calc_grad) then
3694 *
3695 * Radial derivatives. First process both termini of the fragment (i,j)
3696 *
3697           ggg(1)=fac*xj
3698           ggg(2)=fac*yj
3699           ggg(3)=fac*zj
3700           do k=1,3
3701             ghalf=0.5D0*ggg(k)
3702             gelc(k,i)=gelc(k,i)+ghalf
3703             gelc(k,j)=gelc(k,j)+ghalf
3704           enddo
3705 *
3706 * Loop over residues i+1 thru j-1.
3707 *
3708           do k=i+1,j-1
3709             do l=1,3
3710               gelc(l,k)=gelc(l,k)+ggg(l)
3711             enddo
3712           enddo
3713 #endif
3714 *
3715 * Angular part
3716 *
3717           ecosa=2.0D0*fac3*fac1+fac4
3718           fac4=-3.0D0*fac4
3719           fac3=-6.0D0*fac3
3720           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3721           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3722           do k=1,3
3723             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3724             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3725           enddo
3726 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3727 cd   &          (dcosg(k),k=1,3)
3728           do k=1,3
3729             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3730           enddo
3731           do k=1,3
3732             ghalf=0.5D0*ggg(k)
3733             gelc(k,i)=gelc(k,i)+ghalf
3734      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3735      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3736             gelc(k,j)=gelc(k,j)+ghalf
3737      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3738      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3739           enddo
3740           do k=i+1,j-1
3741             do l=1,3
3742               gelc(l,k)=gelc(l,k)+ggg(l)
3743             enddo
3744           enddo
3745           endif
3746
3747           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3748      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3749      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3750 C
3751 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3752 C   energy of a peptide unit is assumed in the form of a second-order
3753 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3754 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3755 C   are computed for EVERY pair of non-contiguous peptide groups.
3756 C
3757           if (j.lt.nres-1) then
3758             j1=j+1
3759             j2=j-1
3760           else
3761             j1=j-1
3762             j2=j-2
3763           endif
3764           kkk=0
3765           do k=1,2
3766             do l=1,2
3767               kkk=kkk+1
3768               muij(kkk)=mu(k,i)*mu(l,j)
3769             enddo
3770           enddo
3771 cd         write (iout,*) 'EELEC: i',i,' j',j
3772 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3773 cd          write(iout,*) 'muij',muij
3774           ury=scalar(uy(1,i),erij)
3775           urz=scalar(uz(1,i),erij)
3776           vry=scalar(uy(1,j),erij)
3777           vrz=scalar(uz(1,j),erij)
3778           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3779           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3780           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3781           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3782 C For diagnostics only
3783 cd          a22=1.0d0
3784 cd          a23=1.0d0
3785 cd          a32=1.0d0
3786 cd          a33=1.0d0
3787           fac=dsqrt(-ael6i)*r3ij
3788 cd          write (2,*) 'fac=',fac
3789 C For diagnostics only
3790 cd          fac=1.0d0
3791           a22=a22*fac
3792           a23=a23*fac
3793           a32=a32*fac
3794           a33=a33*fac
3795 cd          write (iout,'(4i5,4f10.5)')
3796 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3797 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3798 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
3799 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
3800 cd          write (iout,'(4f10.5)')
3801 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3802 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3803 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3804 cd           write (iout,'(2i3,9f10.5/)') i,j,
3805 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3806           if (calc_grad) then
3807 C Derivatives of the elements of A in virtual-bond vectors
3808           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3809 cd          do k=1,3
3810 cd            do l=1,3
3811 cd              erder(k,l)=0.0d0
3812 cd            enddo
3813 cd          enddo
3814           do k=1,3
3815             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3816             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3817             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3818             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3819             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3820             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3821             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3822             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3823             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3824             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3825             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3826             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3827           enddo
3828 cd          do k=1,3
3829 cd            do l=1,3
3830 cd              uryg(k,l)=0.0d0
3831 cd              urzg(k,l)=0.0d0
3832 cd              vryg(k,l)=0.0d0
3833 cd              vrzg(k,l)=0.0d0
3834 cd            enddo
3835 cd          enddo
3836 C Compute radial contributions to the gradient
3837           facr=-3.0d0*rrmij
3838           a22der=a22*facr
3839           a23der=a23*facr
3840           a32der=a32*facr
3841           a33der=a33*facr
3842 cd          a22der=0.0d0
3843 cd          a23der=0.0d0
3844 cd          a32der=0.0d0
3845 cd          a33der=0.0d0
3846           agg(1,1)=a22der*xj
3847           agg(2,1)=a22der*yj
3848           agg(3,1)=a22der*zj
3849           agg(1,2)=a23der*xj
3850           agg(2,2)=a23der*yj
3851           agg(3,2)=a23der*zj
3852           agg(1,3)=a32der*xj
3853           agg(2,3)=a32der*yj
3854           agg(3,3)=a32der*zj
3855           agg(1,4)=a33der*xj
3856           agg(2,4)=a33der*yj
3857           agg(3,4)=a33der*zj
3858 C Add the contributions coming from er
3859           fac3=-3.0d0*fac
3860           do k=1,3
3861             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3862             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3863             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3864             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3865           enddo
3866           do k=1,3
3867 C Derivatives in DC(i)
3868             ghalf1=0.5d0*agg(k,1)
3869             ghalf2=0.5d0*agg(k,2)
3870             ghalf3=0.5d0*agg(k,3)
3871             ghalf4=0.5d0*agg(k,4)
3872             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3873      &      -3.0d0*uryg(k,2)*vry)+ghalf1
3874             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3875      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
3876             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3877      &      -3.0d0*urzg(k,2)*vry)+ghalf3
3878             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3879      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
3880 C Derivatives in DC(i+1)
3881             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3882      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
3883             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3884      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
3885             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3886      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
3887             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3888      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
3889 C Derivatives in DC(j)
3890             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3891      &      -3.0d0*vryg(k,2)*ury)+ghalf1
3892             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3893      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
3894             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3895      &      -3.0d0*vryg(k,2)*urz)+ghalf3
3896             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3897      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
3898 C Derivatives in DC(j+1) or DC(nres-1)
3899             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3900      &      -3.0d0*vryg(k,3)*ury)
3901             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3902      &      -3.0d0*vrzg(k,3)*ury)
3903             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3904      &      -3.0d0*vryg(k,3)*urz)
3905             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3906      &      -3.0d0*vrzg(k,3)*urz)
3907 cd            aggi(k,1)=ghalf1
3908 cd            aggi(k,2)=ghalf2
3909 cd            aggi(k,3)=ghalf3
3910 cd            aggi(k,4)=ghalf4
3911 C Derivatives in DC(i+1)
3912 cd            aggi1(k,1)=agg(k,1)
3913 cd            aggi1(k,2)=agg(k,2)
3914 cd            aggi1(k,3)=agg(k,3)
3915 cd            aggi1(k,4)=agg(k,4)
3916 C Derivatives in DC(j)
3917 cd            aggj(k,1)=ghalf1
3918 cd            aggj(k,2)=ghalf2
3919 cd            aggj(k,3)=ghalf3
3920 cd            aggj(k,4)=ghalf4
3921 C Derivatives in DC(j+1)
3922 cd            aggj1(k,1)=0.0d0
3923 cd            aggj1(k,2)=0.0d0
3924 cd            aggj1(k,3)=0.0d0
3925 cd            aggj1(k,4)=0.0d0
3926             if (j.eq.nres-1 .and. i.lt.j-2) then
3927               do l=1,4
3928                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
3929 cd                aggj1(k,l)=agg(k,l)
3930               enddo
3931             endif
3932           enddo
3933           endif
3934 c          goto 11111
3935 C Check the loc-el terms by numerical integration
3936           acipa(1,1)=a22
3937           acipa(1,2)=a23
3938           acipa(2,1)=a32
3939           acipa(2,2)=a33
3940           a22=-a22
3941           a23=-a23
3942           do l=1,2
3943             do k=1,3
3944               agg(k,l)=-agg(k,l)
3945               aggi(k,l)=-aggi(k,l)
3946               aggi1(k,l)=-aggi1(k,l)
3947               aggj(k,l)=-aggj(k,l)
3948               aggj1(k,l)=-aggj1(k,l)
3949             enddo
3950           enddo
3951           if (j.lt.nres-1) then
3952             a22=-a22
3953             a32=-a32
3954             do l=1,3,2
3955               do k=1,3
3956                 agg(k,l)=-agg(k,l)
3957                 aggi(k,l)=-aggi(k,l)
3958                 aggi1(k,l)=-aggi1(k,l)
3959                 aggj(k,l)=-aggj(k,l)
3960                 aggj1(k,l)=-aggj1(k,l)
3961               enddo
3962             enddo
3963           else
3964             a22=-a22
3965             a23=-a23
3966             a32=-a32
3967             a33=-a33
3968             do l=1,4
3969               do k=1,3
3970                 agg(k,l)=-agg(k,l)
3971                 aggi(k,l)=-aggi(k,l)
3972                 aggi1(k,l)=-aggi1(k,l)
3973                 aggj(k,l)=-aggj(k,l)
3974                 aggj1(k,l)=-aggj1(k,l)
3975               enddo
3976             enddo
3977           endif
3978           ENDIF ! WCORR
3979 11111     continue
3980           IF (wel_loc.gt.0.0d0) THEN
3981 C Contribution to the local-electrostatic energy coming from the i-j pair
3982           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3983      &     +a33*muij(4)
3984 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3985 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3986           eel_loc=eel_loc+eel_loc_ij
3987 C Partial derivatives in virtual-bond dihedral angles gamma
3988           if (calc_grad) then
3989           if (i.gt.1)
3990      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3991      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3992      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3993           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3994      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3995      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3996 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
3997 cd          write(iout,*) 'agg  ',agg
3998 cd          write(iout,*) 'aggi ',aggi
3999 cd          write(iout,*) 'aggi1',aggi1
4000 cd          write(iout,*) 'aggj ',aggj
4001 cd          write(iout,*) 'aggj1',aggj1
4002
4003 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4004           do l=1,3
4005             ggg(l)=agg(l,1)*muij(1)+
4006      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4007           enddo
4008           do k=i+2,j2
4009             do l=1,3
4010               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4011             enddo
4012           enddo
4013 C Remaining derivatives of eello
4014           do l=1,3
4015             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
4016      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
4017             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
4018      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
4019             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
4020      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
4021             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
4022      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
4023           enddo
4024           endif
4025           ENDIF
4026           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4027 C Contributions from turns
4028             a_temp(1,1)=a22
4029             a_temp(1,2)=a23
4030             a_temp(2,1)=a32
4031             a_temp(2,2)=a33
4032             call eturn34(i,j,eello_turn3,eello_turn4)
4033           endif
4034 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4035           if (j.gt.i+1 .and. num_conti.le.maxconts) then
4036 C
4037 C Calculate the contact function. The ith column of the array JCONT will
4038 C contain the numbers of atoms that make contacts with the atom I (of numbers
4039 C greater than I). The arrays FACONT and GACONT will contain the values of
4040 C the contact function and its derivative.
4041 c           r0ij=1.02D0*rpp(iteli,itelj)
4042 c           r0ij=1.11D0*rpp(iteli,itelj)
4043             r0ij=2.20D0*rpp(iteli,itelj)
4044 c           r0ij=1.55D0*rpp(iteli,itelj)
4045             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4046             if (fcont.gt.0.0D0) then
4047               num_conti=num_conti+1
4048               if (num_conti.gt.maxconts) then
4049                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4050      &                         ' will skip next contacts for this conf.'
4051               else
4052                 jcont_hb(num_conti,i)=j
4053                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4054      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4055 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4056 C  terms.
4057                 d_cont(num_conti,i)=rij
4058 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4059 C     --- Electrostatic-interaction matrix ---
4060                 a_chuj(1,1,num_conti,i)=a22
4061                 a_chuj(1,2,num_conti,i)=a23
4062                 a_chuj(2,1,num_conti,i)=a32
4063                 a_chuj(2,2,num_conti,i)=a33
4064 C     --- Gradient of rij
4065                 do kkk=1,3
4066                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4067                 enddo
4068 c             if (i.eq.1) then
4069 c                a_chuj(1,1,num_conti,i)=-0.61d0
4070 c                a_chuj(1,2,num_conti,i)= 0.4d0
4071 c                a_chuj(2,1,num_conti,i)= 0.65d0
4072 c                a_chuj(2,2,num_conti,i)= 0.50d0
4073 c             else if (i.eq.2) then
4074 c                a_chuj(1,1,num_conti,i)= 0.0d0
4075 c                a_chuj(1,2,num_conti,i)= 0.0d0
4076 c                a_chuj(2,1,num_conti,i)= 0.0d0
4077 c                a_chuj(2,2,num_conti,i)= 0.0d0
4078 c             endif
4079 C     --- and its gradients
4080 cd                write (iout,*) 'i',i,' j',j
4081 cd                do kkk=1,3
4082 cd                write (iout,*) 'iii 1 kkk',kkk
4083 cd                write (iout,*) agg(kkk,:)
4084 cd                enddo
4085 cd                do kkk=1,3
4086 cd                write (iout,*) 'iii 2 kkk',kkk
4087 cd                write (iout,*) aggi(kkk,:)
4088 cd                enddo
4089 cd                do kkk=1,3
4090 cd                write (iout,*) 'iii 3 kkk',kkk
4091 cd                write (iout,*) aggi1(kkk,:)
4092 cd                enddo
4093 cd                do kkk=1,3
4094 cd                write (iout,*) 'iii 4 kkk',kkk
4095 cd                write (iout,*) aggj(kkk,:)
4096 cd                enddo
4097 cd                do kkk=1,3
4098 cd                write (iout,*) 'iii 5 kkk',kkk
4099 cd                write (iout,*) aggj1(kkk,:)
4100 cd                enddo
4101                 kkll=0
4102                 do k=1,2
4103                   do l=1,2
4104                     kkll=kkll+1
4105                     do m=1,3
4106                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4107                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4108                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4109                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4110                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4111 c                      do mm=1,5
4112 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
4113 c                      enddo
4114                     enddo
4115                   enddo
4116                 enddo
4117                 ENDIF
4118                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4119 C Calculate contact energies
4120                 cosa4=4.0D0*cosa
4121                 wij=cosa-3.0D0*cosb*cosg
4122                 cosbg1=cosb+cosg
4123                 cosbg2=cosb-cosg
4124 c               fac3=dsqrt(-ael6i)/r0ij**3
4125                 fac3=dsqrt(-ael6i)*r3ij
4126                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4127                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4128 c               ees0mij=0.0D0
4129                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4130                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4131 C Diagnostics. Comment out or remove after debugging!
4132 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4133 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4134 c               ees0m(num_conti,i)=0.0D0
4135 C End diagnostics.
4136 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4137 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4138                 facont_hb(num_conti,i)=fcont
4139                 if (calc_grad) then
4140 C Angular derivatives of the contact function
4141                 ees0pij1=fac3/ees0pij
4142                 ees0mij1=fac3/ees0mij
4143                 fac3p=-3.0D0*fac3*rrmij
4144                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4145                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4146 c               ees0mij1=0.0D0
4147                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4148                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4149                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4150                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4151                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4152                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4153                 ecosap=ecosa1+ecosa2
4154                 ecosbp=ecosb1+ecosb2
4155                 ecosgp=ecosg1+ecosg2
4156                 ecosam=ecosa1-ecosa2
4157                 ecosbm=ecosb1-ecosb2
4158                 ecosgm=ecosg1-ecosg2
4159 C Diagnostics
4160 c               ecosap=ecosa1
4161 c               ecosbp=ecosb1
4162 c               ecosgp=ecosg1
4163 c               ecosam=0.0D0
4164 c               ecosbm=0.0D0
4165 c               ecosgm=0.0D0
4166 C End diagnostics
4167                 fprimcont=fprimcont/rij
4168 cd              facont_hb(num_conti,i)=1.0D0
4169 C Following line is for diagnostics.
4170 cd              fprimcont=0.0D0
4171                 do k=1,3
4172                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4173                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4174                 enddo
4175                 do k=1,3
4176                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4177                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4178                 enddo
4179                 gggp(1)=gggp(1)+ees0pijp*xj
4180                 gggp(2)=gggp(2)+ees0pijp*yj
4181                 gggp(3)=gggp(3)+ees0pijp*zj
4182                 gggm(1)=gggm(1)+ees0mijp*xj
4183                 gggm(2)=gggm(2)+ees0mijp*yj
4184                 gggm(3)=gggm(3)+ees0mijp*zj
4185 C Derivatives due to the contact function
4186                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4187                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4188                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4189                 do k=1,3
4190                   ghalfp=0.5D0*gggp(k)
4191                   ghalfm=0.5D0*gggm(k)
4192                   gacontp_hb1(k,num_conti,i)=ghalfp
4193      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4194      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4195                   gacontp_hb2(k,num_conti,i)=ghalfp
4196      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4197      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4198                   gacontp_hb3(k,num_conti,i)=gggp(k)
4199                   gacontm_hb1(k,num_conti,i)=ghalfm
4200      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4201      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4202                   gacontm_hb2(k,num_conti,i)=ghalfm
4203      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4204      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4205                   gacontm_hb3(k,num_conti,i)=gggm(k)
4206                 enddo
4207                 endif
4208 C Diagnostics. Comment out or remove after debugging!
4209 cdiag           do k=1,3
4210 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4211 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4212 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4213 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4214 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4215 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4216 cdiag           enddo
4217               ENDIF ! wcorr
4218               endif  ! num_conti.le.maxconts
4219             endif  ! fcont.gt.0
4220           endif    ! j.gt.i+1
4221  1216     continue
4222         enddo ! j
4223         num_cont_hb(i)=num_conti
4224  1215   continue
4225       enddo   ! i
4226 cd      do i=1,nres
4227 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
4228 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
4229 cd      enddo
4230 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
4231 ccc      eel_loc=eel_loc+eello_turn3
4232       return
4233       end
4234 C-----------------------------------------------------------------------------
4235       subroutine eturn34(i,j,eello_turn3,eello_turn4)
4236 C Third- and fourth-order contributions from turns
4237       implicit real*8 (a-h,o-z)
4238       include 'DIMENSIONS'
4239       include 'DIMENSIONS.ZSCOPT'
4240       include 'COMMON.IOUNITS'
4241       include 'COMMON.GEO'
4242       include 'COMMON.VAR'
4243       include 'COMMON.LOCAL'
4244       include 'COMMON.CHAIN'
4245       include 'COMMON.DERIV'
4246       include 'COMMON.INTERACT'
4247       include 'COMMON.CONTACTS'
4248       include 'COMMON.TORSION'
4249       include 'COMMON.VECTORS'
4250       include 'COMMON.FFIELD'
4251       dimension ggg(3)
4252       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4253      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4254      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
4255       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4256      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
4257       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
4258       if (j.eq.i+2) then
4259 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4260 C
4261 C               Third-order contributions
4262 C
4263 C                 (i+2)o----(i+3)
4264 C                      | |
4265 C                      | |
4266 C                 (i+1)o----i
4267 C
4268 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4269 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4270         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4271         call transpose2(auxmat(1,1),auxmat1(1,1))
4272         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4273         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4274 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4275 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4276 cd     &    ' eello_turn3_num',4*eello_turn3_num
4277         if (calc_grad) then
4278 C Derivatives in gamma(i)
4279         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4280         call transpose2(auxmat2(1,1),pizda(1,1))
4281         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
4282         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4283 C Derivatives in gamma(i+1)
4284         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4285         call transpose2(auxmat2(1,1),pizda(1,1))
4286         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
4287         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4288      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4289 C Cartesian derivatives
4290         do l=1,3
4291           a_temp(1,1)=aggi(l,1)
4292           a_temp(1,2)=aggi(l,2)
4293           a_temp(2,1)=aggi(l,3)
4294           a_temp(2,2)=aggi(l,4)
4295           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4296           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4297      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4298           a_temp(1,1)=aggi1(l,1)
4299           a_temp(1,2)=aggi1(l,2)
4300           a_temp(2,1)=aggi1(l,3)
4301           a_temp(2,2)=aggi1(l,4)
4302           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4303           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4304      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4305           a_temp(1,1)=aggj(l,1)
4306           a_temp(1,2)=aggj(l,2)
4307           a_temp(2,1)=aggj(l,3)
4308           a_temp(2,2)=aggj(l,4)
4309           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4310           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4311      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4312           a_temp(1,1)=aggj1(l,1)
4313           a_temp(1,2)=aggj1(l,2)
4314           a_temp(2,1)=aggj1(l,3)
4315           a_temp(2,2)=aggj1(l,4)
4316           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4317           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4318      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4319         enddo
4320         endif
4321       else if (j.eq.i+3) then
4322 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4323 C
4324 C               Fourth-order contributions
4325 C
4326 C                 (i+3)o----(i+4)
4327 C                     /  |
4328 C               (i+2)o   |
4329 C                     \  |
4330 C                 (i+1)o----i
4331 C
4332 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4333 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4334         iti1=itortyp(itype(i+1))
4335         iti2=itortyp(itype(i+2))
4336         iti3=itortyp(itype(i+3))
4337         call transpose2(EUg(1,1,i+1),e1t(1,1))
4338         call transpose2(Eug(1,1,i+2),e2t(1,1))
4339         call transpose2(Eug(1,1,i+3),e3t(1,1))
4340         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4341         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4342         s1=scalar2(b1(1,iti2),auxvec(1))
4343         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4344         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4345         s2=scalar2(b1(1,iti1),auxvec(1))
4346         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4347         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4348         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4349         eello_turn4=eello_turn4-(s1+s2+s3)
4350 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4351 cd     &    ' eello_turn4_num',8*eello_turn4_num
4352 C Derivatives in gamma(i)
4353         if (calc_grad) then
4354         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4355         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4356         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4357         s1=scalar2(b1(1,iti2),auxvec(1))
4358         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4359         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4360         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4361 C Derivatives in gamma(i+1)
4362         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4363         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4364         s2=scalar2(b1(1,iti1),auxvec(1))
4365         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4366         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4367         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4368         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4369 C Derivatives in gamma(i+2)
4370         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4371         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4372         s1=scalar2(b1(1,iti2),auxvec(1))
4373         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4374         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4375         s2=scalar2(b1(1,iti1),auxvec(1))
4376         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
4377         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4378         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4379         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4380 C Cartesian derivatives
4381 C Derivatives of this turn contributions in DC(i+2)
4382         if (j.lt.nres-1) then
4383           do l=1,3
4384             a_temp(1,1)=agg(l,1)
4385             a_temp(1,2)=agg(l,2)
4386             a_temp(2,1)=agg(l,3)
4387             a_temp(2,2)=agg(l,4)
4388             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4389             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4390             s1=scalar2(b1(1,iti2),auxvec(1))
4391             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4392             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4393             s2=scalar2(b1(1,iti1),auxvec(1))
4394             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4395             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4396             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4397             ggg(l)=-(s1+s2+s3)
4398             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4399           enddo
4400         endif
4401 C Remaining derivatives of this turn contribution
4402         do l=1,3
4403           a_temp(1,1)=aggi(l,1)
4404           a_temp(1,2)=aggi(l,2)
4405           a_temp(2,1)=aggi(l,3)
4406           a_temp(2,2)=aggi(l,4)
4407           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4408           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4409           s1=scalar2(b1(1,iti2),auxvec(1))
4410           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4411           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4412           s2=scalar2(b1(1,iti1),auxvec(1))
4413           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4414           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4415           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4416           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4417           a_temp(1,1)=aggi1(l,1)
4418           a_temp(1,2)=aggi1(l,2)
4419           a_temp(2,1)=aggi1(l,3)
4420           a_temp(2,2)=aggi1(l,4)
4421           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4422           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4423           s1=scalar2(b1(1,iti2),auxvec(1))
4424           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4425           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4426           s2=scalar2(b1(1,iti1),auxvec(1))
4427           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4428           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4429           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4430           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4431           a_temp(1,1)=aggj(l,1)
4432           a_temp(1,2)=aggj(l,2)
4433           a_temp(2,1)=aggj(l,3)
4434           a_temp(2,2)=aggj(l,4)
4435           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4436           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4437           s1=scalar2(b1(1,iti2),auxvec(1))
4438           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4439           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4440           s2=scalar2(b1(1,iti1),auxvec(1))
4441           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4442           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4443           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4444           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4445           a_temp(1,1)=aggj1(l,1)
4446           a_temp(1,2)=aggj1(l,2)
4447           a_temp(2,1)=aggj1(l,3)
4448           a_temp(2,2)=aggj1(l,4)
4449           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4450           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4451           s1=scalar2(b1(1,iti2),auxvec(1))
4452           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4453           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4454           s2=scalar2(b1(1,iti1),auxvec(1))
4455           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4456           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4457           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4458           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4459         enddo
4460         endif
4461       endif
4462       return
4463       end
4464 C-----------------------------------------------------------------------------
4465       subroutine vecpr(u,v,w)
4466       implicit real*8(a-h,o-z)
4467       dimension u(3),v(3),w(3)
4468       w(1)=u(2)*v(3)-u(3)*v(2)
4469       w(2)=-u(1)*v(3)+u(3)*v(1)
4470       w(3)=u(1)*v(2)-u(2)*v(1)
4471       return
4472       end
4473 C-----------------------------------------------------------------------------
4474       subroutine unormderiv(u,ugrad,unorm,ungrad)
4475 C This subroutine computes the derivatives of a normalized vector u, given
4476 C the derivatives computed without normalization conditions, ugrad. Returns
4477 C ungrad.
4478       implicit none
4479       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4480       double precision vec(3)
4481       double precision scalar
4482       integer i,j
4483 c      write (2,*) 'ugrad',ugrad
4484 c      write (2,*) 'u',u
4485       do i=1,3
4486         vec(i)=scalar(ugrad(1,i),u(1))
4487       enddo
4488 c      write (2,*) 'vec',vec
4489       do i=1,3
4490         do j=1,3
4491           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4492         enddo
4493       enddo
4494 c      write (2,*) 'ungrad',ungrad
4495       return
4496       end
4497 C-----------------------------------------------------------------------------
4498       subroutine escp(evdw2,evdw2_14)
4499 C
4500 C This subroutine calculates the excluded-volume interaction energy between
4501 C peptide-group centers and side chains and its gradient in virtual-bond and
4502 C side-chain vectors.
4503 C
4504       implicit real*8 (a-h,o-z)
4505       include 'DIMENSIONS'
4506       include 'DIMENSIONS.ZSCOPT'
4507       include 'COMMON.GEO'
4508       include 'COMMON.VAR'
4509       include 'COMMON.LOCAL'
4510       include 'COMMON.CHAIN'
4511       include 'COMMON.DERIV'
4512       include 'COMMON.INTERACT'
4513       include 'COMMON.FFIELD'
4514       include 'COMMON.IOUNITS'
4515       dimension ggg(3)
4516       evdw2=0.0D0
4517       evdw2_14=0.0d0
4518 cd    print '(a)','Enter ESCP'
4519 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
4520 c     &  ' scal14',scal14
4521       do i=iatscp_s,iatscp_e
4522         iteli=itel(i)
4523 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
4524 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
4525         if (iteli.eq.0) goto 1225
4526         xi=0.5D0*(c(1,i)+c(1,i+1))
4527         yi=0.5D0*(c(2,i)+c(2,i+1))
4528         zi=0.5D0*(c(3,i)+c(3,i+1))
4529
4530         do iint=1,nscp_gr(i)
4531
4532         do j=iscpstart(i,iint),iscpend(i,iint)
4533           itypj=itype(j)
4534 C Uncomment following three lines for SC-p interactions
4535 c         xj=c(1,nres+j)-xi
4536 c         yj=c(2,nres+j)-yi
4537 c         zj=c(3,nres+j)-zi
4538 C Uncomment following three lines for Ca-p interactions
4539           xj=c(1,j)-xi
4540           yj=c(2,j)-yi
4541           zj=c(3,j)-zi
4542           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4543           fac=rrij**expon2
4544           e1=fac*fac*aad(itypj,iteli)
4545           e2=fac*bad(itypj,iteli)
4546           if (iabs(j-i) .le. 2) then
4547             e1=scal14*e1
4548             e2=scal14*e2
4549             evdw2_14=evdw2_14+e1+e2
4550           endif
4551           evdwij=e1+e2
4552 c          write (iout,*) i,j,evdwij
4553           evdw2=evdw2+evdwij
4554           if (calc_grad) then
4555 C
4556 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4557 C
4558           fac=-(evdwij+e1)*rrij
4559           ggg(1)=xj*fac
4560           ggg(2)=yj*fac
4561           ggg(3)=zj*fac
4562           if (j.lt.i) then
4563 cd          write (iout,*) 'j<i'
4564 C Uncomment following three lines for SC-p interactions
4565 c           do k=1,3
4566 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4567 c           enddo
4568           else
4569 cd          write (iout,*) 'j>i'
4570             do k=1,3
4571               ggg(k)=-ggg(k)
4572 C Uncomment following line for SC-p interactions
4573 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4574             enddo
4575           endif
4576           do k=1,3
4577             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4578           enddo
4579           kstart=min0(i+1,j)
4580           kend=max0(i-1,j-1)
4581 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4582 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4583           do k=kstart,kend
4584             do l=1,3
4585               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4586             enddo
4587           enddo
4588           endif
4589         enddo
4590         enddo ! iint
4591  1225   continue
4592       enddo ! i
4593       do i=1,nct
4594         do j=1,3
4595           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4596           gradx_scp(j,i)=expon*gradx_scp(j,i)
4597         enddo
4598       enddo
4599 C******************************************************************************
4600 C
4601 C                              N O T E !!!
4602 C
4603 C To save time the factor EXPON has been extracted from ALL components
4604 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4605 C use!
4606 C
4607 C******************************************************************************
4608       return
4609       end
4610 C--------------------------------------------------------------------------
4611       subroutine edis(ehpb)
4612 C
4613 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4614 C
4615       implicit real*8 (a-h,o-z)
4616       include 'DIMENSIONS'
4617       include 'COMMON.SBRIDGE'
4618       include 'COMMON.CHAIN'
4619       include 'COMMON.DERIV'
4620       include 'COMMON.VAR'
4621       include 'COMMON.INTERACT'
4622       include 'COMMON.IOUNITS'
4623       dimension ggg(3)
4624       ehpb=0.0D0
4625 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4626 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4627       if (link_end.eq.0) return
4628       do i=link_start,link_end
4629 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4630 C CA-CA distance used in regularization of structure.
4631         ii=ihpb(i)
4632         jj=jhpb(i)
4633 C iii and jjj point to the residues for which the distance is assigned.
4634         if (ii.gt.nres) then
4635           iii=ii-nres
4636           jjj=jj-nres
4637         else
4638           iii=ii
4639           jjj=jj
4640         endif
4641 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4642 c     &    dhpb(i),dhpb1(i),forcon(i)
4643 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4644 C    distance and angle dependent SS bond potential.
4645         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4646           call ssbond_ene(iii,jjj,eij)
4647           ehpb=ehpb+2*eij
4648 cd          write (iout,*) "eij",eij
4649         else if (ii.gt.nres .and. jj.gt.nres) then
4650 c Restraints from contact prediction
4651           dd=dist(ii,jj)
4652           if (dhpb1(i).gt.0.0d0) then
4653             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4654             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4655 c            write (iout,*) "beta nmr",
4656 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4657           else
4658             dd=dist(ii,jj)
4659             rdis=dd-dhpb(i)
4660 C Get the force constant corresponding to this distance.
4661             waga=forcon(i)
4662 C Calculate the contribution to energy.
4663             ehpb=ehpb+waga*rdis*rdis
4664 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4665 C
4666 C Evaluate gradient.
4667 C
4668             fac=waga*rdis/dd
4669           endif
4670           do j=1,3
4671             ggg(j)=fac*(c(j,jj)-c(j,ii))
4672           enddo
4673           do j=1,3
4674             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4675             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4676           enddo
4677           do k=1,3
4678             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4679             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4680           enddo
4681         else
4682 C Calculate the distance between the two points and its difference from the
4683 C target distance.
4684           dd=dist(ii,jj)
4685           if (dhpb1(i).gt.0.0d0) then
4686             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4687             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4688 c            write (iout,*) "alph nmr",
4689 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4690           else
4691             rdis=dd-dhpb(i)
4692 C Get the force constant corresponding to this distance.
4693             waga=forcon(i)
4694 C Calculate the contribution to energy.
4695             ehpb=ehpb+waga*rdis*rdis
4696 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4697 C
4698 C Evaluate gradient.
4699 C
4700             fac=waga*rdis/dd
4701           endif
4702 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4703 cd   &   ' waga=',waga,' fac=',fac
4704             do j=1,3
4705               ggg(j)=fac*(c(j,jj)-c(j,ii))
4706             enddo
4707 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4708 C If this is a SC-SC distance, we need to calculate the contributions to the
4709 C Cartesian gradient in the SC vectors (ghpbx).
4710           if (iii.lt.ii) then
4711           do j=1,3
4712             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4713             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4714           enddo
4715           endif
4716           do k=1,3
4717             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4718             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4719           enddo
4720         endif
4721       enddo
4722       ehpb=0.5D0*ehpb
4723       return
4724       end
4725 C--------------------------------------------------------------------------
4726       subroutine ssbond_ene(i,j,eij)
4727 C
4728 C Calculate the distance and angle dependent SS-bond potential energy
4729 C using a free-energy function derived based on RHF/6-31G** ab initio
4730 C calculations of diethyl disulfide.
4731 C
4732 C A. Liwo and U. Kozlowska, 11/24/03
4733 C
4734       implicit real*8 (a-h,o-z)
4735       include 'DIMENSIONS'
4736       include 'DIMENSIONS.ZSCOPT'
4737       include 'COMMON.SBRIDGE'
4738       include 'COMMON.CHAIN'
4739       include 'COMMON.DERIV'
4740       include 'COMMON.LOCAL'
4741       include 'COMMON.INTERACT'
4742       include 'COMMON.VAR'
4743       include 'COMMON.IOUNITS'
4744       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4745       itypi=itype(i)
4746       xi=c(1,nres+i)
4747       yi=c(2,nres+i)
4748       zi=c(3,nres+i)
4749       dxi=dc_norm(1,nres+i)
4750       dyi=dc_norm(2,nres+i)
4751       dzi=dc_norm(3,nres+i)
4752       dsci_inv=dsc_inv(itypi)
4753       itypj=itype(j)
4754       dscj_inv=dsc_inv(itypj)
4755       xj=c(1,nres+j)-xi
4756       yj=c(2,nres+j)-yi
4757       zj=c(3,nres+j)-zi
4758       dxj=dc_norm(1,nres+j)
4759       dyj=dc_norm(2,nres+j)
4760       dzj=dc_norm(3,nres+j)
4761       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4762       rij=dsqrt(rrij)
4763       erij(1)=xj*rij
4764       erij(2)=yj*rij
4765       erij(3)=zj*rij
4766       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4767       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4768       om12=dxi*dxj+dyi*dyj+dzi*dzj
4769       do k=1,3
4770         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4771         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4772       enddo
4773       rij=1.0d0/rij
4774       deltad=rij-d0cm
4775       deltat1=1.0d0-om1
4776       deltat2=1.0d0+om2
4777       deltat12=om2-om1+2.0d0
4778       cosphi=om12-om1*om2
4779       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4780      &  +akct*deltad*deltat12
4781      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4782 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4783 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4784 c     &  " deltat12",deltat12," eij",eij
4785       ed=2*akcm*deltad+akct*deltat12
4786       pom1=akct*deltad
4787       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4788       eom1=-2*akth*deltat1-pom1-om2*pom2
4789       eom2= 2*akth*deltat2+pom1-om1*pom2
4790       eom12=pom2
4791       do k=1,3
4792         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4793       enddo
4794       do k=1,3
4795         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4796      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4797         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4798      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4799       enddo
4800 C
4801 C Calculate the components of the gradient in DC and X
4802 C
4803       do k=i,j-1
4804         do l=1,3
4805           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4806         enddo
4807       enddo
4808       return
4809       end
4810 C--------------------------------------------------------------------------
4811       subroutine ebond(estr)
4812 c
4813 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4814 c
4815       implicit real*8 (a-h,o-z)
4816       include 'DIMENSIONS'
4817       include 'DIMENSIONS.ZSCOPT'
4818       include 'COMMON.LOCAL'
4819       include 'COMMON.GEO'
4820       include 'COMMON.INTERACT'
4821       include 'COMMON.DERIV'
4822       include 'COMMON.VAR'
4823       include 'COMMON.CHAIN'
4824       include 'COMMON.IOUNITS'
4825       include 'COMMON.NAMES'
4826       include 'COMMON.FFIELD'
4827       include 'COMMON.CONTROL'
4828       double precision u(3),ud(3)
4829       estr=0.0d0
4830       do i=nnt+1,nct
4831         diff = vbld(i)-vbldp0
4832 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4833         estr=estr+diff*diff
4834         do j=1,3
4835           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4836         enddo
4837       enddo
4838       estr=0.5d0*AKP*estr
4839 c
4840 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4841 c
4842       do i=nnt,nct
4843         iti=itype(i)
4844         if (iti.ne.10) then
4845           nbi=nbondterm(iti)
4846           if (nbi.eq.1) then
4847             diff=vbld(i+nres)-vbldsc0(1,iti)
4848 <<<<<<< HEAD
4849             write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4850      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4851 =======
4852 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4853 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4854 >>>>>>> e183793... Added src_MD-M-newcorr (Adasko's source) and src-NEWSC of WHAM (with Momo's SCSC potentials)
4855             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4856             do j=1,3
4857               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4858             enddo
4859           else
4860             do j=1,nbi
4861               diff=vbld(i+nres)-vbldsc0(j,iti)
4862               ud(j)=aksc(j,iti)*diff
4863               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4864             enddo
4865             uprod=u(1)
4866             do j=2,nbi
4867               uprod=uprod*u(j)
4868             enddo
4869             usum=0.0d0
4870             usumsqder=0.0d0
4871             do j=1,nbi
4872               uprod1=1.0d0
4873               uprod2=1.0d0
4874               do k=1,nbi
4875                 if (k.ne.j) then
4876                   uprod1=uprod1*u(k)
4877                   uprod2=uprod2*u(k)*u(k)
4878                 endif
4879               enddo
4880               usum=usum+uprod1
4881               usumsqder=usumsqder+ud(j)*uprod2
4882             enddo
4883 <<<<<<< HEAD
4884             write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4885      &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4886 =======
4887 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4888 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4889 >>>>>>> e183793... Added src_MD-M-newcorr (Adasko's source) and src-NEWSC of WHAM (with Momo's SCSC potentials)
4890             estr=estr+uprod/usum
4891             do j=1,3
4892              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4893             enddo
4894           endif
4895         endif
4896       enddo
4897       return
4898       end
4899 #ifdef CRYST_THETA
4900 C--------------------------------------------------------------------------
4901       subroutine ebend(etheta)
4902 C
4903 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4904 C angles gamma and its derivatives in consecutive thetas and gammas.
4905 C
4906       implicit real*8 (a-h,o-z)
4907       include 'DIMENSIONS'
4908       include 'DIMENSIONS.ZSCOPT'
4909       include 'COMMON.LOCAL'
4910       include 'COMMON.GEO'
4911       include 'COMMON.INTERACT'
4912       include 'COMMON.DERIV'
4913       include 'COMMON.VAR'
4914       include 'COMMON.CHAIN'
4915       include 'COMMON.IOUNITS'
4916       include 'COMMON.NAMES'
4917       include 'COMMON.FFIELD'
4918       common /calcthet/ term1,term2,termm,diffak,ratak,
4919      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4920      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4921       double precision y(2),z(2)
4922       delta=0.02d0*pi
4923       time11=dexp(-2*time)
4924       time12=1.0d0
4925       etheta=0.0D0
4926 c      write (iout,*) "nres",nres
4927 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4928 c      write (iout,*) ithet_start,ithet_end
4929       do i=ithet_start,ithet_end
4930 C Zero the energy function and its derivative at 0 or pi.
4931         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4932         it=itype(i-1)
4933 c        if (i.gt.ithet_start .and.
4934 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
4935 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
4936 c          phii=phi(i)
4937 c          y(1)=dcos(phii)
4938 c          y(2)=dsin(phii)
4939 c        else
4940 c          y(1)=0.0D0
4941 c          y(2)=0.0D0
4942 c        endif
4943 c        if (i.lt.nres .and. itel(i).ne.0) then
4944 c          phii1=phi(i+1)
4945 c          z(1)=dcos(phii1)
4946 c          z(2)=dsin(phii1)
4947 c        else
4948 c          z(1)=0.0D0
4949 c          z(2)=0.0D0
4950 c        endif
4951         if (i.gt.3) then
4952 #ifdef OSF
4953           phii=phi(i)
4954           icrc=0
4955           call proc_proc(phii,icrc)
4956           if (icrc.eq.1) phii=150.0
4957 #else
4958           phii=phi(i)
4959 #endif
4960           y(1)=dcos(phii)
4961           y(2)=dsin(phii)
4962         else
4963           y(1)=0.0D0
4964           y(2)=0.0D0
4965         endif
4966         if (i.lt.nres) then
4967 #ifdef OSF
4968           phii1=phi(i+1)
4969           icrc=0
4970           call proc_proc(phii1,icrc)
4971           if (icrc.eq.1) phii1=150.0
4972           phii1=pinorm(phii1)
4973           z(1)=cos(phii1)
4974 #else
4975           phii1=phi(i+1)
4976           z(1)=dcos(phii1)
4977 #endif
4978           z(2)=dsin(phii1)
4979         else
4980           z(1)=0.0D0
4981           z(2)=0.0D0
4982         endif
4983 C Calculate the "mean" value of theta from the part of the distribution
4984 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4985 C In following comments this theta will be referred to as t_c.
4986         thet_pred_mean=0.0d0
4987         do k=1,2
4988           athetk=athet(k,it)
4989           bthetk=bthet(k,it)
4990           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4991         enddo
4992 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4993         dthett=thet_pred_mean*ssd
4994         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4995 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4996 C Derivatives of the "mean" values in gamma1 and gamma2.
4997         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4998         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4999         if (theta(i).gt.pi-delta) then
5000           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5001      &         E_tc0)
5002           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5003           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5004           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5005      &        E_theta)
5006           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5007      &        E_tc)
5008         else if (theta(i).lt.delta) then
5009           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5010           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5011           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5012      &        E_theta)
5013           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5014           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5015      &        E_tc)
5016         else
5017           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5018      &        E_theta,E_tc)
5019         endif
5020         etheta=etheta+ethetai
5021 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5022 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5023         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5024         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5025         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5026  1215   continue
5027       enddo
5028 C Ufff.... We've done all this!!!
5029       return
5030       end
5031 C---------------------------------------------------------------------------
5032       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5033      &     E_tc)
5034       implicit real*8 (a-h,o-z)
5035       include 'DIMENSIONS'
5036       include 'COMMON.LOCAL'
5037       include 'COMMON.IOUNITS'
5038       common /calcthet/ term1,term2,termm,diffak,ratak,
5039      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5040      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5041 C Calculate the contributions to both Gaussian lobes.
5042 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5043 C The "polynomial part" of the "standard deviation" of this part of
5044 C the distribution.
5045         sig=polthet(3,it)
5046         do j=2,0,-1
5047           sig=sig*thet_pred_mean+polthet(j,it)
5048         enddo
5049 C Derivative of the "interior part" of the "standard deviation of the"
5050 C gamma-dependent Gaussian lobe in t_c.
5051         sigtc=3*polthet(3,it)
5052         do j=2,1,-1
5053           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5054         enddo
5055         sigtc=sig*sigtc
5056 C Set the parameters of both Gaussian lobes of the distribution.
5057 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5058         fac=sig*sig+sigc0(it)
5059         sigcsq=fac+fac
5060         sigc=1.0D0/sigcsq
5061 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5062         sigsqtc=-4.0D0*sigcsq*sigtc
5063 c       print *,i,sig,sigtc,sigsqtc
5064 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5065         sigtc=-sigtc/(fac*fac)
5066 C Following variable is sigma(t_c)**(-2)
5067         sigcsq=sigcsq*sigcsq
5068         sig0i=sig0(it)
5069         sig0inv=1.0D0/sig0i**2
5070         delthec=thetai-thet_pred_mean
5071         delthe0=thetai-theta0i
5072         term1=-0.5D0*sigcsq*delthec*delthec
5073         term2=-0.5D0*sig0inv*delthe0*delthe0
5074 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5075 C NaNs in taking the logarithm. We extract the largest exponent which is added
5076 C to the energy (this being the log of the distribution) at the end of energy
5077 C term evaluation for this virtual-bond angle.
5078         if (term1.gt.term2) then
5079           termm=term1
5080           term2=dexp(term2-termm)
5081           term1=1.0d0
5082         else
5083           termm=term2
5084           term1=dexp(term1-termm)
5085           term2=1.0d0
5086         endif
5087 C The ratio between the gamma-independent and gamma-dependent lobes of
5088 C the distribution is a Gaussian function of thet_pred_mean too.
5089         diffak=gthet(2,it)-thet_pred_mean
5090         ratak=diffak/gthet(3,it)**2
5091         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5092 C Let's differentiate it in thet_pred_mean NOW.
5093         aktc=ak*ratak
5094 C Now put together the distribution terms to make complete distribution.
5095         termexp=term1+ak*term2
5096         termpre=sigc+ak*sig0i
5097 C Contribution of the bending energy from this theta is just the -log of
5098 C the sum of the contributions from the two lobes and the pre-exponential
5099 C factor. Simple enough, isn't it?
5100         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5101 C NOW the derivatives!!!
5102 C 6/6/97 Take into account the deformation.
5103         E_theta=(delthec*sigcsq*term1
5104      &       +ak*delthe0*sig0inv*term2)/termexp
5105         E_tc=((sigtc+aktc*sig0i)/termpre
5106      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5107      &       aktc*term2)/termexp)
5108       return
5109       end
5110 c-----------------------------------------------------------------------------
5111       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5112       implicit real*8 (a-h,o-z)
5113       include 'DIMENSIONS'
5114       include 'COMMON.LOCAL'
5115       include 'COMMON.IOUNITS'
5116       common /calcthet/ term1,term2,termm,diffak,ratak,
5117      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5118      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5119       delthec=thetai-thet_pred_mean
5120       delthe0=thetai-theta0i
5121 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5122       t3 = thetai-thet_pred_mean
5123       t6 = t3**2
5124       t9 = term1
5125       t12 = t3*sigcsq
5126       t14 = t12+t6*sigsqtc
5127       t16 = 1.0d0
5128       t21 = thetai-theta0i
5129       t23 = t21**2
5130       t26 = term2
5131       t27 = t21*t26
5132       t32 = termexp
5133       t40 = t32**2
5134       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5135      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5136      & *(-t12*t9-ak*sig0inv*t27)
5137       return
5138       end
5139 #else
5140 C--------------------------------------------------------------------------
5141       subroutine ebend(etheta)
5142 C
5143 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5144 C angles gamma and its derivatives in consecutive thetas and gammas.
5145 C ab initio-derived potentials from
5146 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5147 C
5148       implicit real*8 (a-h,o-z)
5149       include 'DIMENSIONS'
5150       include 'DIMENSIONS.ZSCOPT'
5151       include 'COMMON.LOCAL'
5152       include 'COMMON.GEO'
5153       include 'COMMON.INTERACT'
5154       include 'COMMON.DERIV'
5155       include 'COMMON.VAR'
5156       include 'COMMON.CHAIN'
5157       include 'COMMON.IOUNITS'
5158       include 'COMMON.NAMES'
5159       include 'COMMON.FFIELD'
5160       include 'COMMON.CONTROL'
5161       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5162      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5163      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5164      & sinph1ph2(maxdouble,maxdouble)
5165       logical lprn /.false./, lprn1 /.false./
5166       etheta=0.0D0
5167 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5168       do i=ithet_start,ithet_end
5169         dethetai=0.0d0
5170         dephii=0.0d0
5171         dephii1=0.0d0
5172         theti2=0.5d0*theta(i)
5173         ityp2=ithetyp(itype(i-1))
5174         do k=1,nntheterm
5175           coskt(k)=dcos(k*theti2)
5176           sinkt(k)=dsin(k*theti2)
5177         enddo
5178         if (i.gt.3) then
5179 #ifdef OSF
5180           phii=phi(i)
5181           if (phii.ne.phii) phii=150.0
5182 #else
5183           phii=phi(i)
5184 #endif
5185           ityp1=ithetyp(itype(i-2))
5186           do k=1,nsingle
5187             cosph1(k)=dcos(k*phii)
5188             sinph1(k)=dsin(k*phii)
5189           enddo
5190         else
5191           phii=0.0d0
5192           ityp1=nthetyp+1
5193           do k=1,nsingle
5194             cosph1(k)=0.0d0
5195             sinph1(k)=0.0d0
5196           enddo
5197         endif
5198         if (i.lt.nres) then
5199 #ifdef OSF
5200           phii1=phi(i+1)
5201           if (phii1.ne.phii1) phii1=150.0
5202           phii1=pinorm(phii1)
5203 #else
5204           phii1=phi(i+1)
5205 #endif
5206           ityp3=ithetyp(itype(i))
5207           do k=1,nsingle
5208             cosph2(k)=dcos(k*phii1)
5209             sinph2(k)=dsin(k*phii1)
5210           enddo
5211         else
5212           phii1=0.0d0
5213           ityp3=nthetyp+1
5214           do k=1,nsingle
5215             cosph2(k)=0.0d0
5216             sinph2(k)=0.0d0
5217           enddo
5218         endif
5219 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5220 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5221 c        call flush(iout)
5222         ethetai=aa0thet(ityp1,ityp2,ityp3)
5223         do k=1,ndouble
5224           do l=1,k-1
5225             ccl=cosph1(l)*cosph2(k-l)
5226             ssl=sinph1(l)*sinph2(k-l)
5227             scl=sinph1(l)*cosph2(k-l)
5228             csl=cosph1(l)*sinph2(k-l)
5229             cosph1ph2(l,k)=ccl-ssl
5230             cosph1ph2(k,l)=ccl+ssl
5231             sinph1ph2(l,k)=scl+csl
5232             sinph1ph2(k,l)=scl-csl
5233           enddo
5234         enddo
5235         if (lprn) then
5236         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5237      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5238         write (iout,*) "coskt and sinkt"
5239         do k=1,nntheterm
5240           write (iout,*) k,coskt(k),sinkt(k)
5241         enddo
5242         endif
5243         do k=1,ntheterm
5244           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
5245           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
5246      &      *coskt(k)
5247           if (lprn)
5248      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
5249      &     " ethetai",ethetai
5250         enddo
5251         if (lprn) then
5252         write (iout,*) "cosph and sinph"
5253         do k=1,nsingle
5254           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5255         enddo
5256         write (iout,*) "cosph1ph2 and sinph2ph2"
5257         do k=2,ndouble
5258           do l=1,k-1
5259             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5260      &         sinph1ph2(l,k),sinph1ph2(k,l)
5261           enddo
5262         enddo
5263         write(iout,*) "ethetai",ethetai
5264         endif
5265         do m=1,ntheterm2
5266           do k=1,nsingle
5267             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
5268      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
5269      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
5270      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
5271             ethetai=ethetai+sinkt(m)*aux
5272             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5273             dephii=dephii+k*sinkt(m)*(
5274      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
5275      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
5276             dephii1=dephii1+k*sinkt(m)*(
5277      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
5278      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
5279             if (lprn)
5280      &      write (iout,*) "m",m," k",k," bbthet",
5281      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
5282      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
5283      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
5284      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5285           enddo
5286         enddo
5287         if (lprn)
5288      &  write(iout,*) "ethetai",ethetai
5289         do m=1,ntheterm3
5290           do k=2,ndouble
5291             do l=1,k-1
5292               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5293      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
5294      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5295      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
5296               ethetai=ethetai+sinkt(m)*aux
5297               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5298               dephii=dephii+l*sinkt(m)*(
5299      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
5300      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5301      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5302      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5303               dephii1=dephii1+(k-l)*sinkt(m)*(
5304      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5305      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5306      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5307      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5308               if (lprn) then
5309               write (iout,*) "m",m," k",k," l",l," ffthet",
5310      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5311      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5312      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5313      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5314               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5315      &            cosph1ph2(k,l)*sinkt(m),
5316      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5317               endif
5318             enddo
5319           enddo
5320         enddo
5321 10      continue
5322         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5323      &   i,theta(i)*rad2deg,phii*rad2deg,
5324      &   phii1*rad2deg,ethetai
5325         etheta=etheta+ethetai
5326         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5327         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5328         gloc(nphi+i-2,icg)=wang*dethetai
5329       enddo
5330       return
5331       end
5332 #endif
5333 #ifdef CRYST_SC
5334 c-----------------------------------------------------------------------------
5335       subroutine esc(escloc)
5336 C Calculate the local energy of a side chain and its derivatives in the
5337 C corresponding virtual-bond valence angles THETA and the spherical angles
5338 C ALPHA and OMEGA.
5339       implicit real*8 (a-h,o-z)
5340       include 'DIMENSIONS'
5341       include 'DIMENSIONS.ZSCOPT'
5342       include 'COMMON.GEO'
5343       include 'COMMON.LOCAL'
5344       include 'COMMON.VAR'
5345       include 'COMMON.INTERACT'
5346       include 'COMMON.DERIV'
5347       include 'COMMON.CHAIN'
5348       include 'COMMON.IOUNITS'
5349       include 'COMMON.NAMES'
5350       include 'COMMON.FFIELD'
5351       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5352      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5353       common /sccalc/ time11,time12,time112,theti,it,nlobit
5354       delta=0.02d0*pi
5355       escloc=0.0D0
5356 c     write (iout,'(a)') 'ESC'
5357       do i=loc_start,loc_end
5358         it=itype(i)
5359         if (it.eq.10) goto 1
5360         nlobit=nlob(it)
5361 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5362 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5363         theti=theta(i+1)-pipol
5364         x(1)=dtan(theti)
5365         x(2)=alph(i)
5366         x(3)=omeg(i)
5367 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5368
5369         if (x(2).gt.pi-delta) then
5370           xtemp(1)=x(1)
5371           xtemp(2)=pi-delta
5372           xtemp(3)=x(3)
5373           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5374           xtemp(2)=pi
5375           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5376           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5377      &        escloci,dersc(2))
5378           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5379      &        ddersc0(1),dersc(1))
5380           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5381      &        ddersc0(3),dersc(3))
5382           xtemp(2)=pi-delta
5383           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5384           xtemp(2)=pi
5385           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5386           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5387      &            dersc0(2),esclocbi,dersc02)
5388           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5389      &            dersc12,dersc01)
5390           call splinthet(x(2),0.5d0*delta,ss,ssd)
5391           dersc0(1)=dersc01
5392           dersc0(2)=dersc02
5393           dersc0(3)=0.0d0
5394           do k=1,3
5395             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5396           enddo
5397           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5398 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5399 c    &             esclocbi,ss,ssd
5400           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5401 c         escloci=esclocbi
5402 c         write (iout,*) escloci
5403         else if (x(2).lt.delta) then
5404           xtemp(1)=x(1)
5405           xtemp(2)=delta
5406           xtemp(3)=x(3)
5407           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5408           xtemp(2)=0.0d0
5409           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5410           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5411      &        escloci,dersc(2))
5412           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5413      &        ddersc0(1),dersc(1))
5414           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5415      &        ddersc0(3),dersc(3))
5416           xtemp(2)=delta
5417           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5418           xtemp(2)=0.0d0
5419           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5420           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5421      &            dersc0(2),esclocbi,dersc02)
5422           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5423      &            dersc12,dersc01)
5424           dersc0(1)=dersc01
5425           dersc0(2)=dersc02
5426           dersc0(3)=0.0d0
5427           call splinthet(x(2),0.5d0*delta,ss,ssd)
5428           do k=1,3
5429             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5430           enddo
5431           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5432 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5433 c    &             esclocbi,ss,ssd
5434           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5435 c         write (iout,*) escloci
5436         else
5437           call enesc(x,escloci,dersc,ddummy,.false.)
5438         endif
5439
5440         escloc=escloc+escloci
5441 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5442
5443         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5444      &   wscloc*dersc(1)
5445         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5446         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5447     1   continue
5448       enddo
5449       return
5450       end
5451 C---------------------------------------------------------------------------
5452       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5453       implicit real*8 (a-h,o-z)
5454       include 'DIMENSIONS'
5455       include 'COMMON.GEO'
5456       include 'COMMON.LOCAL'
5457       include 'COMMON.IOUNITS'
5458       common /sccalc/ time11,time12,time112,theti,it,nlobit
5459       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5460       double precision contr(maxlob,-1:1)
5461       logical mixed
5462 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5463         escloc_i=0.0D0
5464         do j=1,3
5465           dersc(j)=0.0D0
5466           if (mixed) ddersc(j)=0.0d0
5467         enddo
5468         x3=x(3)
5469
5470 C Because of periodicity of the dependence of the SC energy in omega we have
5471 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5472 C To avoid underflows, first compute & store the exponents.
5473
5474         do iii=-1,1
5475
5476           x(3)=x3+iii*dwapi
5477
5478           do j=1,nlobit
5479             do k=1,3
5480               z(k)=x(k)-censc(k,j,it)
5481             enddo
5482             do k=1,3
5483               Axk=0.0D0
5484               do l=1,3
5485                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5486               enddo
5487               Ax(k,j,iii)=Axk
5488             enddo
5489             expfac=0.0D0
5490             do k=1,3
5491               expfac=expfac+Ax(k,j,iii)*z(k)
5492             enddo
5493             contr(j,iii)=expfac
5494           enddo ! j
5495
5496         enddo ! iii
5497
5498         x(3)=x3
5499 C As in the case of ebend, we want to avoid underflows in exponentiation and
5500 C subsequent NaNs and INFs in energy calculation.
5501 C Find the largest exponent
5502         emin=contr(1,-1)
5503         do iii=-1,1
5504           do j=1,nlobit
5505             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5506           enddo
5507         enddo
5508         emin=0.5D0*emin
5509 cd      print *,'it=',it,' emin=',emin
5510
5511 C Compute the contribution to SC energy and derivatives
5512         do iii=-1,1
5513
5514           do j=1,nlobit
5515             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5516 cd          print *,'j=',j,' expfac=',expfac
5517             escloc_i=escloc_i+expfac
5518             do k=1,3
5519               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5520             enddo
5521             if (mixed) then
5522               do k=1,3,2
5523                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5524      &            +gaussc(k,2,j,it))*expfac
5525               enddo
5526             endif
5527           enddo
5528
5529         enddo ! iii
5530
5531         dersc(1)=dersc(1)/cos(theti)**2
5532         ddersc(1)=ddersc(1)/cos(theti)**2
5533         ddersc(3)=ddersc(3)
5534
5535         escloci=-(dlog(escloc_i)-emin)
5536         do j=1,3
5537           dersc(j)=dersc(j)/escloc_i
5538         enddo
5539         if (mixed) then
5540           do j=1,3,2
5541             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5542           enddo
5543         endif
5544       return
5545       end
5546 C------------------------------------------------------------------------------
5547       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5548       implicit real*8 (a-h,o-z)
5549       include 'DIMENSIONS'
5550       include 'COMMON.GEO'
5551       include 'COMMON.LOCAL'
5552       include 'COMMON.IOUNITS'
5553       common /sccalc/ time11,time12,time112,theti,it,nlobit
5554       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5555       double precision contr(maxlob)
5556       logical mixed
5557
5558       escloc_i=0.0D0
5559
5560       do j=1,3
5561         dersc(j)=0.0D0
5562       enddo
5563
5564       do j=1,nlobit
5565         do k=1,2
5566           z(k)=x(k)-censc(k,j,it)
5567         enddo
5568         z(3)=dwapi
5569         do k=1,3
5570           Axk=0.0D0
5571           do l=1,3
5572             Axk=Axk+gaussc(l,k,j,it)*z(l)
5573           enddo
5574           Ax(k,j)=Axk
5575         enddo
5576         expfac=0.0D0
5577         do k=1,3
5578           expfac=expfac+Ax(k,j)*z(k)
5579         enddo
5580         contr(j)=expfac
5581       enddo ! j
5582
5583 C As in the case of ebend, we want to avoid underflows in exponentiation and
5584 C subsequent NaNs and INFs in energy calculation.
5585 C Find the largest exponent
5586       emin=contr(1)
5587       do j=1,nlobit
5588         if (emin.gt.contr(j)) emin=contr(j)
5589       enddo
5590       emin=0.5D0*emin
5591
5592 C Compute the contribution to SC energy and derivatives
5593
5594       dersc12=0.0d0
5595       do j=1,nlobit
5596         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5597         escloc_i=escloc_i+expfac
5598         do k=1,2
5599           dersc(k)=dersc(k)+Ax(k,j)*expfac
5600         enddo
5601         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5602      &            +gaussc(1,2,j,it))*expfac
5603         dersc(3)=0.0d0
5604       enddo
5605
5606       dersc(1)=dersc(1)/cos(theti)**2
5607       dersc12=dersc12/cos(theti)**2
5608       escloci=-(dlog(escloc_i)-emin)
5609       do j=1,2
5610         dersc(j)=dersc(j)/escloc_i
5611       enddo
5612       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5613       return
5614       end
5615 #else
5616 c----------------------------------------------------------------------------------
5617       subroutine esc(escloc)
5618 C Calculate the local energy of a side chain and its derivatives in the
5619 C corresponding virtual-bond valence angles THETA and the spherical angles
5620 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5621 C added by Urszula Kozlowska. 07/11/2007
5622 C
5623       implicit real*8 (a-h,o-z)
5624       include 'DIMENSIONS'
5625       include 'DIMENSIONS.ZSCOPT'
5626       include 'COMMON.GEO'
5627       include 'COMMON.LOCAL'
5628       include 'COMMON.VAR'
5629       include 'COMMON.SCROT'
5630       include 'COMMON.INTERACT'
5631       include 'COMMON.DERIV'
5632       include 'COMMON.CHAIN'
5633       include 'COMMON.IOUNITS'
5634       include 'COMMON.NAMES'
5635       include 'COMMON.FFIELD'
5636       include 'COMMON.CONTROL'
5637       include 'COMMON.VECTORS'
5638       double precision x_prime(3),y_prime(3),z_prime(3)
5639      &    , sumene,dsc_i,dp2_i,x(65),
5640      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5641      &    de_dxx,de_dyy,de_dzz,de_dt
5642       double precision s1_t,s1_6_t,s2_t,s2_6_t
5643       double precision
5644      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5645      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5646      & dt_dCi(3),dt_dCi1(3)
5647       common /sccalc/ time11,time12,time112,theti,it,nlobit
5648       delta=0.02d0*pi
5649       escloc=0.0D0
5650       do i=loc_start,loc_end
5651         costtab(i+1) =dcos(theta(i+1))
5652         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5653         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5654         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5655         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5656         cosfac=dsqrt(cosfac2)
5657         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5658         sinfac=dsqrt(sinfac2)
5659         it=itype(i)
5660         if (it.eq.10) goto 1
5661 c
5662 C  Compute the axes of tghe local cartesian coordinates system; store in
5663 c   x_prime, y_prime and z_prime
5664 c
5665         do j=1,3
5666           x_prime(j) = 0.00
5667           y_prime(j) = 0.00
5668           z_prime(j) = 0.00
5669         enddo
5670 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5671 C     &   dc_norm(3,i+nres)
5672         do j = 1,3
5673           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5674           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5675         enddo
5676         do j = 1,3
5677           z_prime(j) = -uz(j,i-1)
5678         enddo
5679 c       write (2,*) "i",i
5680 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5681 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5682 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5683 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5684 c      & " xy",scalar(x_prime(1),y_prime(1)),
5685 c      & " xz",scalar(x_prime(1),z_prime(1)),
5686 c      & " yy",scalar(y_prime(1),y_prime(1)),
5687 c      & " yz",scalar(y_prime(1),z_prime(1)),
5688 c      & " zz",scalar(z_prime(1),z_prime(1))
5689 c
5690 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5691 C to local coordinate system. Store in xx, yy, zz.
5692 c
5693         xx=0.0d0
5694         yy=0.0d0
5695         zz=0.0d0
5696         do j = 1,3
5697           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5698           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5699           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5700         enddo
5701
5702         xxtab(i)=xx
5703         yytab(i)=yy
5704         zztab(i)=zz
5705 C
5706 C Compute the energy of the ith side cbain
5707 C
5708 c        write (2,*) "xx",xx," yy",yy," zz",zz
5709         it=itype(i)
5710         do j = 1,65
5711           x(j) = sc_parmin(j,it)
5712         enddo
5713 #ifdef CHECK_COORD
5714 Cc diagnostics - remove later
5715         xx1 = dcos(alph(2))
5716         yy1 = dsin(alph(2))*dcos(omeg(2))
5717         zz1 = -dsin(alph(2))*dsin(omeg(2))
5718         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5719      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5720      &    xx1,yy1,zz1
5721 C,"  --- ", xx_w,yy_w,zz_w
5722 c end diagnostics
5723 #endif
5724         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5725      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5726      &   + x(10)*yy*zz
5727         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5728      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5729      & + x(20)*yy*zz
5730         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5731      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5732      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5733      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5734      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5735      &  +x(40)*xx*yy*zz
5736         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5737      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5738      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5739      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5740      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5741      &  +x(60)*xx*yy*zz
5742         dsc_i   = 0.743d0+x(61)
5743         dp2_i   = 1.9d0+x(62)
5744         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5745      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5746         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5747      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5748         s1=(1+x(63))/(0.1d0 + dscp1)
5749         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5750         s2=(1+x(65))/(0.1d0 + dscp2)
5751         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5752         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5753      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5754 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5755 c     &   sumene4,
5756 c     &   dscp1,dscp2,sumene
5757 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5758         escloc = escloc + sumene
5759 c        write (2,*) "escloc",escloc
5760         if (.not. calc_grad) goto 1
5761 #ifdef DEBUG
5762 C
5763 C This section to check the numerical derivatives of the energy of ith side
5764 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5765 C #define DEBUG in the code to turn it on.
5766 C
5767         write (2,*) "sumene               =",sumene
5768         aincr=1.0d-7
5769         xxsave=xx
5770         xx=xx+aincr
5771         write (2,*) xx,yy,zz
5772         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5773         de_dxx_num=(sumenep-sumene)/aincr
5774         xx=xxsave
5775         write (2,*) "xx+ sumene from enesc=",sumenep
5776         yysave=yy
5777         yy=yy+aincr
5778         write (2,*) xx,yy,zz
5779         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5780         de_dyy_num=(sumenep-sumene)/aincr
5781         yy=yysave
5782         write (2,*) "yy+ sumene from enesc=",sumenep
5783         zzsave=zz
5784         zz=zz+aincr
5785         write (2,*) xx,yy,zz
5786         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5787         de_dzz_num=(sumenep-sumene)/aincr
5788         zz=zzsave
5789         write (2,*) "zz+ sumene from enesc=",sumenep
5790         costsave=cost2tab(i+1)
5791         sintsave=sint2tab(i+1)
5792         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5793         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5794         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5795         de_dt_num=(sumenep-sumene)/aincr
5796         write (2,*) " t+ sumene from enesc=",sumenep
5797         cost2tab(i+1)=costsave
5798         sint2tab(i+1)=sintsave
5799 C End of diagnostics section.
5800 #endif
5801 C
5802 C Compute the gradient of esc
5803 C
5804         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5805         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5806         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5807         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5808         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5809         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5810         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5811         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5812         pom1=(sumene3*sint2tab(i+1)+sumene1)
5813      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5814         pom2=(sumene4*cost2tab(i+1)+sumene2)
5815      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5816         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5817         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5818      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5819      &  +x(40)*yy*zz
5820         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5821         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5822      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5823      &  +x(60)*yy*zz
5824         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5825      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5826      &        +(pom1+pom2)*pom_dx
5827 #ifdef DEBUG
5828         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5829 #endif
5830 C
5831         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5832         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5833      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5834      &  +x(40)*xx*zz
5835         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5836         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5837      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5838      &  +x(59)*zz**2 +x(60)*xx*zz
5839         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5840      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5841      &        +(pom1-pom2)*pom_dy
5842 #ifdef DEBUG
5843         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5844 #endif
5845 C
5846         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5847      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5848      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5849      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5850      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5851      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5852      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5853      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5854 #ifdef DEBUG
5855         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5856 #endif
5857 C
5858         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5859      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5860      &  +pom1*pom_dt1+pom2*pom_dt2
5861 #ifdef DEBUG
5862         write(2,*), "de_dt = ", de_dt,de_dt_num
5863 #endif
5864 c
5865 C
5866        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5867        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5868        cosfac2xx=cosfac2*xx
5869        sinfac2yy=sinfac2*yy
5870        do k = 1,3
5871          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5872      &      vbld_inv(i+1)
5873          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5874      &      vbld_inv(i)
5875          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5876          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5877 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5878 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5879 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5880 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5881          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5882          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5883          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5884          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5885          dZZ_Ci1(k)=0.0d0
5886          dZZ_Ci(k)=0.0d0
5887          do j=1,3
5888            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5889            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5890          enddo
5891
5892          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5893          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5894          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5895 c
5896          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5897          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5898        enddo
5899
5900        do k=1,3
5901          dXX_Ctab(k,i)=dXX_Ci(k)
5902          dXX_C1tab(k,i)=dXX_Ci1(k)
5903          dYY_Ctab(k,i)=dYY_Ci(k)
5904          dYY_C1tab(k,i)=dYY_Ci1(k)
5905          dZZ_Ctab(k,i)=dZZ_Ci(k)
5906          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5907          dXX_XYZtab(k,i)=dXX_XYZ(k)
5908          dYY_XYZtab(k,i)=dYY_XYZ(k)
5909          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5910        enddo
5911
5912        do k = 1,3
5913 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5914 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5915 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5916 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5917 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5918 c     &    dt_dci(k)
5919 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5920 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5921          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5922      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5923          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5924      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5925          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5926      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5927        enddo
5928 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5929 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5930
5931 C to check gradient call subroutine check_grad
5932
5933     1 continue
5934       enddo
5935       return
5936       end
5937 #endif
5938 c------------------------------------------------------------------------------
5939       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5940 C
5941 C This procedure calculates two-body contact function g(rij) and its derivative:
5942 C
5943 C           eps0ij                                     !       x < -1
5944 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5945 C            0                                         !       x > 1
5946 C
5947 C where x=(rij-r0ij)/delta
5948 C
5949 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5950 C
5951       implicit none
5952       double precision rij,r0ij,eps0ij,fcont,fprimcont
5953       double precision x,x2,x4,delta
5954 c     delta=0.02D0*r0ij
5955 c      delta=0.2D0*r0ij
5956       x=(rij-r0ij)/delta
5957       if (x.lt.-1.0D0) then
5958         fcont=eps0ij
5959         fprimcont=0.0D0
5960       else if (x.le.1.0D0) then
5961         x2=x*x
5962         x4=x2*x2
5963         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5964         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5965       else
5966         fcont=0.0D0
5967         fprimcont=0.0D0
5968       endif
5969       return
5970       end
5971 c------------------------------------------------------------------------------
5972       subroutine splinthet(theti,delta,ss,ssder)
5973       implicit real*8 (a-h,o-z)
5974       include 'DIMENSIONS'
5975       include 'DIMENSIONS.ZSCOPT'
5976       include 'COMMON.VAR'
5977       include 'COMMON.GEO'
5978       thetup=pi-delta
5979       thetlow=delta
5980       if (theti.gt.pipol) then
5981         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5982       else
5983         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5984         ssder=-ssder
5985       endif
5986       return
5987       end
5988 c------------------------------------------------------------------------------
5989       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5990       implicit none
5991       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5992       double precision ksi,ksi2,ksi3,a1,a2,a3
5993       a1=fprim0*delta/(f1-f0)
5994       a2=3.0d0-2.0d0*a1
5995       a3=a1-2.0d0
5996       ksi=(x-x0)/delta
5997       ksi2=ksi*ksi
5998       ksi3=ksi2*ksi
5999       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6000       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6001       return
6002       end
6003 c------------------------------------------------------------------------------
6004       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6005       implicit none
6006       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6007       double precision ksi,ksi2,ksi3,a1,a2,a3
6008       ksi=(x-x0)/delta
6009       ksi2=ksi*ksi
6010       ksi3=ksi2*ksi
6011       a1=fprim0x*delta
6012       a2=3*(f1x-f0x)-2*fprim0x*delta
6013       a3=fprim0x*delta-2*(f1x-f0x)
6014       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6015       return
6016       end
6017 C-----------------------------------------------------------------------------
6018 #ifdef CRYST_TOR
6019 C-----------------------------------------------------------------------------
6020       subroutine etor(etors,edihcnstr,fact)
6021       implicit real*8 (a-h,o-z)
6022       include 'DIMENSIONS'
6023       include 'DIMENSIONS.ZSCOPT'
6024       include 'COMMON.VAR'
6025       include 'COMMON.GEO'
6026       include 'COMMON.LOCAL'
6027       include 'COMMON.TORSION'
6028       include 'COMMON.INTERACT'
6029       include 'COMMON.DERIV'
6030       include 'COMMON.CHAIN'
6031       include 'COMMON.NAMES'
6032       include 'COMMON.IOUNITS'
6033       include 'COMMON.FFIELD'
6034       include 'COMMON.TORCNSTR'
6035       logical lprn
6036 C Set lprn=.true. for debugging
6037       lprn=.false.
6038 c      lprn=.true.
6039       etors=0.0D0
6040       do i=iphi_start,iphi_end
6041         itori=itortyp(itype(i-2))
6042         itori1=itortyp(itype(i-1))
6043         phii=phi(i)
6044         gloci=0.0D0
6045 C Proline-Proline pair is a special case...
6046         if (itori.eq.3 .and. itori1.eq.3) then
6047           if (phii.gt.-dwapi3) then
6048             cosphi=dcos(3*phii)
6049             fac=1.0D0/(1.0D0-cosphi)
6050             etorsi=v1(1,3,3)*fac
6051             etorsi=etorsi+etorsi
6052             etors=etors+etorsi-v1(1,3,3)
6053             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6054           endif
6055           do j=1,3
6056             v1ij=v1(j+1,itori,itori1)
6057             v2ij=v2(j+1,itori,itori1)
6058             cosphi=dcos(j*phii)
6059             sinphi=dsin(j*phii)
6060             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6061             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6062           enddo
6063         else
6064           do j=1,nterm_old
6065             v1ij=v1(j,itori,itori1)
6066             v2ij=v2(j,itori,itori1)
6067             cosphi=dcos(j*phii)
6068             sinphi=dsin(j*phii)
6069             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6070             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6071           enddo
6072         endif
6073         if (lprn)
6074      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6075      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6076      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6077         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6078 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6079       enddo
6080 ! 6/20/98 - dihedral angle constraints
6081       edihcnstr=0.0d0
6082       do i=1,ndih_constr
6083         itori=idih_constr(i)
6084         phii=phi(itori)
6085         difi=phii-phi0(i)
6086         if (difi.gt.drange(i)) then
6087           difi=difi-drange(i)
6088           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6089           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6090         else if (difi.lt.-drange(i)) then
6091           difi=difi+drange(i)
6092           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6093           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6094         endif
6095 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6096 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6097       enddo
6098 !      write (iout,*) 'edihcnstr',edihcnstr
6099       return
6100       end
6101 c------------------------------------------------------------------------------
6102 #else
6103       subroutine etor(etors,edihcnstr,fact)
6104       implicit real*8 (a-h,o-z)
6105       include 'DIMENSIONS'
6106       include 'DIMENSIONS.ZSCOPT'
6107       include 'COMMON.VAR'
6108       include 'COMMON.GEO'
6109       include 'COMMON.LOCAL'
6110       include 'COMMON.TORSION'
6111       include 'COMMON.INTERACT'
6112       include 'COMMON.DERIV'
6113       include 'COMMON.CHAIN'
6114       include 'COMMON.NAMES'
6115       include 'COMMON.IOUNITS'
6116       include 'COMMON.FFIELD'
6117       include 'COMMON.TORCNSTR'
6118       logical lprn
6119 C Set lprn=.true. for debugging
6120       lprn=.false.
6121 c      lprn=.true.
6122       etors=0.0D0
6123       do i=iphi_start,iphi_end
6124         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6125         itori=itortyp(itype(i-2))
6126         itori1=itortyp(itype(i-1))
6127         phii=phi(i)
6128         gloci=0.0D0
6129 C Regular cosine and sine terms
6130         do j=1,nterm(itori,itori1)
6131           v1ij=v1(j,itori,itori1)
6132           v2ij=v2(j,itori,itori1)
6133           cosphi=dcos(j*phii)
6134           sinphi=dsin(j*phii)
6135           etors=etors+v1ij*cosphi+v2ij*sinphi
6136           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6137         enddo
6138 C Lorentz terms
6139 C                         v1
6140 C  E = SUM ----------------------------------- - v1
6141 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6142 C
6143         cosphi=dcos(0.5d0*phii)
6144         sinphi=dsin(0.5d0*phii)
6145         do j=1,nlor(itori,itori1)
6146           vl1ij=vlor1(j,itori,itori1)
6147           vl2ij=vlor2(j,itori,itori1)
6148           vl3ij=vlor3(j,itori,itori1)
6149           pom=vl2ij*cosphi+vl3ij*sinphi
6150           pom1=1.0d0/(pom*pom+1.0d0)
6151           etors=etors+vl1ij*pom1
6152           pom=-pom*pom1*pom1
6153           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6154         enddo
6155 C Subtract the constant term
6156         etors=etors-v0(itori,itori1)
6157         if (lprn)
6158      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6159      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6160      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6161         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6162 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6163  1215   continue
6164       enddo
6165 ! 6/20/98 - dihedral angle constraints
6166       edihcnstr=0.0d0
6167       do i=1,ndih_constr
6168         itori=idih_constr(i)
6169         phii=phi(itori)
6170         difi=pinorm(phii-phi0(i))
6171         edihi=0.0d0
6172         if (difi.gt.drange(i)) then
6173           difi=difi-drange(i)
6174           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6175           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6176           edihi=0.25d0*ftors*difi**4
6177         else if (difi.lt.-drange(i)) then
6178           difi=difi+drange(i)
6179           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6180           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6181           edihi=0.25d0*ftors*difi**4
6182         else
6183           difi=0.0d0
6184         endif
6185 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
6186 c     &    drange(i),edihi
6187 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6188 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6189       enddo
6190 !      write (iout,*) 'edihcnstr',edihcnstr
6191       return
6192       end
6193 c----------------------------------------------------------------------------
6194       subroutine etor_d(etors_d,fact2)
6195 C 6/23/01 Compute double torsional energy
6196       implicit real*8 (a-h,o-z)
6197       include 'DIMENSIONS'
6198       include 'DIMENSIONS.ZSCOPT'
6199       include 'COMMON.VAR'
6200       include 'COMMON.GEO'
6201       include 'COMMON.LOCAL'
6202       include 'COMMON.TORSION'
6203       include 'COMMON.INTERACT'
6204       include 'COMMON.DERIV'
6205       include 'COMMON.CHAIN'
6206       include 'COMMON.NAMES'
6207       include 'COMMON.IOUNITS'
6208       include 'COMMON.FFIELD'
6209       include 'COMMON.TORCNSTR'
6210       logical lprn
6211 C Set lprn=.true. for debugging
6212       lprn=.false.
6213 c     lprn=.true.
6214       etors_d=0.0D0
6215       do i=iphi_start,iphi_end-1
6216         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6217      &     goto 1215
6218         itori=itortyp(itype(i-2))
6219         itori1=itortyp(itype(i-1))
6220         itori2=itortyp(itype(i))
6221         phii=phi(i)
6222         phii1=phi(i+1)
6223         gloci1=0.0D0
6224         gloci2=0.0D0
6225 C Regular cosine and sine terms
6226         do j=1,ntermd_1(itori,itori1,itori2)
6227           v1cij=v1c(1,j,itori,itori1,itori2)
6228           v1sij=v1s(1,j,itori,itori1,itori2)
6229           v2cij=v1c(2,j,itori,itori1,itori2)
6230           v2sij=v1s(2,j,itori,itori1,itori2)
6231           cosphi1=dcos(j*phii)
6232           sinphi1=dsin(j*phii)
6233           cosphi2=dcos(j*phii1)
6234           sinphi2=dsin(j*phii1)
6235           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6236      &     v2cij*cosphi2+v2sij*sinphi2
6237           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6238           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6239         enddo
6240         do k=2,ntermd_2(itori,itori1,itori2)
6241           do l=1,k-1
6242             v1cdij = v2c(k,l,itori,itori1,itori2)
6243             v2cdij = v2c(l,k,itori,itori1,itori2)
6244             v1sdij = v2s(k,l,itori,itori1,itori2)
6245             v2sdij = v2s(l,k,itori,itori1,itori2)
6246             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6247             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6248             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6249             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6250             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6251      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6252             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6253      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6254             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6255      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6256           enddo
6257         enddo
6258         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6259         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6260  1215   continue
6261       enddo
6262       return
6263       end
6264 #endif
6265 c------------------------------------------------------------------------------
6266       subroutine eback_sc_corr(esccor)
6267 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6268 c        conformational states; temporarily implemented as differences
6269 c        between UNRES torsional potentials (dependent on three types of
6270 c        residues) and the torsional potentials dependent on all 20 types
6271 c        of residues computed from AM1 energy surfaces of terminally-blocked
6272 c        amino-acid residues.
6273       implicit real*8 (a-h,o-z)
6274       include 'DIMENSIONS'
6275       include 'DIMENSIONS.ZSCOPT'
6276       include 'COMMON.VAR'
6277       include 'COMMON.GEO'
6278       include 'COMMON.LOCAL'
6279       include 'COMMON.TORSION'
6280       include 'COMMON.SCCOR'
6281       include 'COMMON.INTERACT'
6282       include 'COMMON.DERIV'
6283       include 'COMMON.CHAIN'
6284       include 'COMMON.NAMES'
6285       include 'COMMON.IOUNITS'
6286       include 'COMMON.FFIELD'
6287       include 'COMMON.CONTROL'
6288       logical lprn
6289 C Set lprn=.true. for debugging
6290       lprn=.false.
6291 c      lprn=.true.
6292 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
6293       esccor=0.0D0
6294       do i=itau_start,itau_end
6295         esccor_ii=0.0D0
6296         isccori=isccortyp(itype(i-2))
6297         isccori1=isccortyp(itype(i-1))
6298         phii=phi(i)
6299 cccc  Added 9 May 2012
6300 cc Tauangle is torsional engle depending on the value of first digit
6301 c(see comment below)
6302 cc Omicron is flat angle depending on the value of first digit
6303 c(see comment below)
6304
6305
6306         do intertyp=1,3 !intertyp
6307 cc Added 09 May 2012 (Adasko)
6308 cc  Intertyp means interaction type of backbone mainchain correlation:
6309 c   1 = SC...Ca...Ca...Ca
6310 c   2 = Ca...Ca...Ca...SC
6311 c   3 = SC...Ca...Ca...SCi
6312         gloci=0.0D0
6313         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6314      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6315      &      (itype(i-1).eq.21)))
6316      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6317      &     .or.(itype(i-2).eq.21)))
6318      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6319      &      (itype(i-1).eq.21)))) cycle
6320         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6321         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6322      & cycle
6323         do j=1,nterm_sccor(isccori,isccori1)
6324           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6325           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6326           cosphi=dcos(j*tauangle(intertyp,i))
6327           sinphi=dsin(j*tauangle(intertyp,i))
6328           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6329           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6330         enddo
6331         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6332 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6333 c     &gloc_sc(intertyp,i-3,icg)
6334         if (lprn)
6335      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6336      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6337      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6338      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6339         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6340        enddo !intertyp
6341       enddo
6342 c        do i=1,nres
6343 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6344 c        enddo
6345       return
6346       end
6347 c------------------------------------------------------------------------------
6348       subroutine multibody(ecorr)
6349 C This subroutine calculates multi-body contributions to energy following
6350 C the idea of Skolnick et al. If side chains I and J make a contact and
6351 C at the same time side chains I+1 and J+1 make a contact, an extra
6352 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6353       implicit real*8 (a-h,o-z)
6354       include 'DIMENSIONS'
6355       include 'COMMON.IOUNITS'
6356       include 'COMMON.DERIV'
6357       include 'COMMON.INTERACT'
6358       include 'COMMON.CONTACTS'
6359       double precision gx(3),gx1(3)
6360       logical lprn
6361
6362 C Set lprn=.true. for debugging
6363       lprn=.false.
6364
6365       if (lprn) then
6366         write (iout,'(a)') 'Contact function values:'
6367         do i=nnt,nct-2
6368           write (iout,'(i2,20(1x,i2,f10.5))')
6369      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6370         enddo
6371       endif
6372       ecorr=0.0D0
6373       do i=nnt,nct
6374         do j=1,3
6375           gradcorr(j,i)=0.0D0
6376           gradxorr(j,i)=0.0D0
6377         enddo
6378       enddo
6379       do i=nnt,nct-2
6380
6381         DO ISHIFT = 3,4
6382
6383         i1=i+ishift
6384         num_conti=num_cont(i)
6385         num_conti1=num_cont(i1)
6386         do jj=1,num_conti
6387           j=jcont(jj,i)
6388           do kk=1,num_conti1
6389             j1=jcont(kk,i1)
6390             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6391 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6392 cd   &                   ' ishift=',ishift
6393 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6394 C The system gains extra energy.
6395               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6396             endif   ! j1==j+-ishift
6397           enddo     ! kk
6398         enddo       ! jj
6399
6400         ENDDO ! ISHIFT
6401
6402       enddo         ! i
6403       return
6404       end
6405 c------------------------------------------------------------------------------
6406       double precision function esccorr(i,j,k,l,jj,kk)
6407       implicit real*8 (a-h,o-z)
6408       include 'DIMENSIONS'
6409       include 'COMMON.IOUNITS'
6410       include 'COMMON.DERIV'
6411       include 'COMMON.INTERACT'
6412       include 'COMMON.CONTACTS'
6413       double precision gx(3),gx1(3)
6414       logical lprn
6415       lprn=.false.
6416       eij=facont(jj,i)
6417       ekl=facont(kk,k)
6418 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6419 C Calculate the multi-body contribution to energy.
6420 C Calculate multi-body contributions to the gradient.
6421 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6422 cd   & k,l,(gacont(m,kk,k),m=1,3)
6423       do m=1,3
6424         gx(m) =ekl*gacont(m,jj,i)
6425         gx1(m)=eij*gacont(m,kk,k)
6426         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6427         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6428         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6429         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6430       enddo
6431       do m=i,j-1
6432         do ll=1,3
6433           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6434         enddo
6435       enddo
6436       do m=k,l-1
6437         do ll=1,3
6438           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6439         enddo
6440       enddo
6441       esccorr=-eij*ekl
6442       return
6443       end
6444 c------------------------------------------------------------------------------
6445 #ifdef MPL
6446       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
6447       implicit real*8 (a-h,o-z)
6448       include 'DIMENSIONS'
6449       integer dimen1,dimen2,atom,indx
6450       double precision buffer(dimen1,dimen2)
6451       double precision zapas
6452       common /contacts_hb/ zapas(3,20,maxres,7),
6453      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6454      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6455       num_kont=num_cont_hb(atom)
6456       do i=1,num_kont
6457         do k=1,7
6458           do j=1,3
6459             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
6460           enddo ! j
6461         enddo ! k
6462         buffer(i,indx+22)=facont_hb(i,atom)
6463         buffer(i,indx+23)=ees0p(i,atom)
6464         buffer(i,indx+24)=ees0m(i,atom)
6465         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
6466       enddo ! i
6467       buffer(1,indx+26)=dfloat(num_kont)
6468       return
6469       end
6470 c------------------------------------------------------------------------------
6471       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
6472       implicit real*8 (a-h,o-z)
6473       include 'DIMENSIONS'
6474       integer dimen1,dimen2,atom,indx
6475       double precision buffer(dimen1,dimen2)
6476       double precision zapas
6477       common /contacts_hb/ zapas(3,20,maxres,7),
6478      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6479      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6480       num_kont=buffer(1,indx+26)
6481       num_kont_old=num_cont_hb(atom)
6482       num_cont_hb(atom)=num_kont+num_kont_old
6483       do i=1,num_kont
6484         ii=i+num_kont_old
6485         do k=1,7
6486           do j=1,3
6487             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
6488           enddo ! j
6489         enddo ! k
6490         facont_hb(ii,atom)=buffer(i,indx+22)
6491         ees0p(ii,atom)=buffer(i,indx+23)
6492         ees0m(ii,atom)=buffer(i,indx+24)
6493         jcont_hb(ii,atom)=buffer(i,indx+25)
6494       enddo ! i
6495       return
6496       end
6497 c------------------------------------------------------------------------------
6498 #endif
6499       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6500 C This subroutine calculates multi-body contributions to hydrogen-bonding
6501       implicit real*8 (a-h,o-z)
6502       include 'DIMENSIONS'
6503       include 'DIMENSIONS.ZSCOPT'
6504       include 'COMMON.IOUNITS'
6505 #ifdef MPL
6506       include 'COMMON.INFO'
6507 #endif
6508       include 'COMMON.FFIELD'
6509       include 'COMMON.DERIV'
6510       include 'COMMON.INTERACT'
6511       include 'COMMON.CONTACTS'
6512 #ifdef MPL
6513       parameter (max_cont=maxconts)
6514       parameter (max_dim=2*(8*3+2))
6515       parameter (msglen1=max_cont*max_dim*4)
6516       parameter (msglen2=2*msglen1)
6517       integer source,CorrelType,CorrelID,Error
6518       double precision buffer(max_cont,max_dim)
6519 #endif
6520       double precision gx(3),gx1(3)
6521       logical lprn,ldone
6522
6523 C Set lprn=.true. for debugging
6524       lprn=.false.
6525 #ifdef MPL
6526       n_corr=0
6527       n_corr1=0
6528       if (fgProcs.le.1) goto 30
6529       if (lprn) then
6530         write (iout,'(a)') 'Contact function values:'
6531         do i=nnt,nct-2
6532           write (iout,'(2i3,50(1x,i2,f5.2))')
6533      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6534      &    j=1,num_cont_hb(i))
6535         enddo
6536       endif
6537 C Caution! Following code assumes that electrostatic interactions concerning
6538 C a given atom are split among at most two processors!
6539       CorrelType=477
6540       CorrelID=MyID+1
6541       ldone=.false.
6542       do i=1,max_cont
6543         do j=1,max_dim
6544           buffer(i,j)=0.0D0
6545         enddo
6546       enddo
6547       mm=mod(MyRank,2)
6548 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6549       if (mm) 20,20,10
6550    10 continue
6551 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6552       if (MyRank.gt.0) then
6553 C Send correlation contributions to the preceding processor
6554         msglen=msglen1
6555         nn=num_cont_hb(iatel_s)
6556         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6557 cd      write (iout,*) 'The BUFFER array:'
6558 cd      do i=1,nn
6559 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6560 cd      enddo
6561         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6562           msglen=msglen2
6563             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6564 C Clear the contacts of the atom passed to the neighboring processor
6565         nn=num_cont_hb(iatel_s+1)
6566 cd      do i=1,nn
6567 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6568 cd      enddo
6569             num_cont_hb(iatel_s)=0
6570         endif
6571 cd      write (iout,*) 'Processor ',MyID,MyRank,
6572 cd   & ' is sending correlation contribution to processor',MyID-1,
6573 cd   & ' msglen=',msglen
6574 cd      write (*,*) 'Processor ',MyID,MyRank,
6575 cd   & ' is sending correlation contribution to processor',MyID-1,
6576 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6577         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6578 cd      write (iout,*) 'Processor ',MyID,
6579 cd   & ' has sent correlation contribution to processor',MyID-1,
6580 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6581 cd      write (*,*) 'Processor ',MyID,
6582 cd   & ' has sent correlation contribution to processor',MyID-1,
6583 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6584         msglen=msglen1
6585       endif ! (MyRank.gt.0)
6586       if (ldone) goto 30
6587       ldone=.true.
6588    20 continue
6589 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6590       if (MyRank.lt.fgProcs-1) then
6591 C Receive correlation contributions from the next processor
6592         msglen=msglen1
6593         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6594 cd      write (iout,*) 'Processor',MyID,
6595 cd   & ' is receiving correlation contribution from processor',MyID+1,
6596 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6597 cd      write (*,*) 'Processor',MyID,
6598 cd   & ' is receiving correlation contribution from processor',MyID+1,
6599 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6600         nbytes=-1
6601         do while (nbytes.le.0)
6602           call mp_probe(MyID+1,CorrelType,nbytes)
6603         enddo
6604 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6605         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6606 cd      write (iout,*) 'Processor',MyID,
6607 cd   & ' has received correlation contribution from processor',MyID+1,
6608 cd   & ' msglen=',msglen,' nbytes=',nbytes
6609 cd      write (iout,*) 'The received BUFFER array:'
6610 cd      do i=1,max_cont
6611 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6612 cd      enddo
6613         if (msglen.eq.msglen1) then
6614           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6615         else if (msglen.eq.msglen2)  then
6616           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6617           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6618         else
6619           write (iout,*)
6620      & 'ERROR!!!! message length changed while processing correlations.'
6621           write (*,*)
6622      & 'ERROR!!!! message length changed while processing correlations.'
6623           call mp_stopall(Error)
6624         endif ! msglen.eq.msglen1
6625       endif ! MyRank.lt.fgProcs-1
6626       if (ldone) goto 30
6627       ldone=.true.
6628       goto 10
6629    30 continue
6630 #endif
6631       if (lprn) then
6632         write (iout,'(a)') 'Contact function values:'
6633         do i=nnt,nct-2
6634           write (iout,'(2i3,50(1x,i2,f5.2))')
6635      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6636      &    j=1,num_cont_hb(i))
6637         enddo
6638       endif
6639       ecorr=0.0D0
6640 C Remove the loop below after debugging !!!
6641       do i=nnt,nct
6642         do j=1,3
6643           gradcorr(j,i)=0.0D0
6644           gradxorr(j,i)=0.0D0
6645         enddo
6646       enddo
6647 C Calculate the local-electrostatic correlation terms
6648       do i=iatel_s,iatel_e+1
6649         i1=i+1
6650         num_conti=num_cont_hb(i)
6651         num_conti1=num_cont_hb(i+1)
6652         do jj=1,num_conti
6653           j=jcont_hb(jj,i)
6654           do kk=1,num_conti1
6655             j1=jcont_hb(kk,i1)
6656 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6657 c     &         ' jj=',jj,' kk=',kk
6658             if (j1.eq.j+1 .or. j1.eq.j-1) then
6659 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6660 C The system gains extra energy.
6661               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6662               n_corr=n_corr+1
6663             else if (j1.eq.j) then
6664 C Contacts I-J and I-(J+1) occur simultaneously.
6665 C The system loses extra energy.
6666 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6667             endif
6668           enddo ! kk
6669           do kk=1,num_conti
6670             j1=jcont_hb(kk,i)
6671 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6672 c    &         ' jj=',jj,' kk=',kk
6673             if (j1.eq.j+1) then
6674 C Contacts I-J and (I+1)-J occur simultaneously.
6675 C The system loses extra energy.
6676 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6677             endif ! j1==j+1
6678           enddo ! kk
6679         enddo ! jj
6680       enddo ! i
6681       return
6682       end
6683 c------------------------------------------------------------------------------
6684       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6685      &  n_corr1)
6686 C This subroutine calculates multi-body contributions to hydrogen-bonding
6687       implicit real*8 (a-h,o-z)
6688       include 'DIMENSIONS'
6689       include 'DIMENSIONS.ZSCOPT'
6690       include 'COMMON.IOUNITS'
6691 #ifdef MPL
6692       include 'COMMON.INFO'
6693 #endif
6694       include 'COMMON.FFIELD'
6695       include 'COMMON.DERIV'
6696       include 'COMMON.INTERACT'
6697       include 'COMMON.CONTACTS'
6698 #ifdef MPL
6699       parameter (max_cont=maxconts)
6700       parameter (max_dim=2*(8*3+2))
6701       parameter (msglen1=max_cont*max_dim*4)
6702       parameter (msglen2=2*msglen1)
6703       integer source,CorrelType,CorrelID,Error
6704       double precision buffer(max_cont,max_dim)
6705 #endif
6706       double precision gx(3),gx1(3)
6707       logical lprn,ldone
6708
6709 C Set lprn=.true. for debugging
6710       lprn=.false.
6711       eturn6=0.0d0
6712 #ifdef MPL
6713       n_corr=0
6714       n_corr1=0
6715       if (fgProcs.le.1) goto 30
6716       if (lprn) then
6717         write (iout,'(a)') 'Contact function values:'
6718         do i=nnt,nct-2
6719           write (iout,'(2i3,50(1x,i2,f5.2))')
6720      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6721      &    j=1,num_cont_hb(i))
6722         enddo
6723       endif
6724 C Caution! Following code assumes that electrostatic interactions concerning
6725 C a given atom are split among at most two processors!
6726       CorrelType=477
6727       CorrelID=MyID+1
6728       ldone=.false.
6729       do i=1,max_cont
6730         do j=1,max_dim
6731           buffer(i,j)=0.0D0
6732         enddo
6733       enddo
6734       mm=mod(MyRank,2)
6735 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6736       if (mm) 20,20,10
6737    10 continue
6738 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6739       if (MyRank.gt.0) then
6740 C Send correlation contributions to the preceding processor
6741         msglen=msglen1
6742         nn=num_cont_hb(iatel_s)
6743         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6744 cd      write (iout,*) 'The BUFFER array:'
6745 cd      do i=1,nn
6746 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6747 cd      enddo
6748         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6749           msglen=msglen2
6750             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6751 C Clear the contacts of the atom passed to the neighboring processor
6752         nn=num_cont_hb(iatel_s+1)
6753 cd      do i=1,nn
6754 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6755 cd      enddo
6756             num_cont_hb(iatel_s)=0
6757         endif
6758 cd      write (iout,*) 'Processor ',MyID,MyRank,
6759 cd   & ' is sending correlation contribution to processor',MyID-1,
6760 cd   & ' msglen=',msglen
6761 cd      write (*,*) 'Processor ',MyID,MyRank,
6762 cd   & ' is sending correlation contribution to processor',MyID-1,
6763 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6764         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6765 cd      write (iout,*) 'Processor ',MyID,
6766 cd   & ' has sent correlation contribution to processor',MyID-1,
6767 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6768 cd      write (*,*) 'Processor ',MyID,
6769 cd   & ' has sent correlation contribution to processor',MyID-1,
6770 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6771         msglen=msglen1
6772       endif ! (MyRank.gt.0)
6773       if (ldone) goto 30
6774       ldone=.true.
6775    20 continue
6776 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6777       if (MyRank.lt.fgProcs-1) then
6778 C Receive correlation contributions from the next processor
6779         msglen=msglen1
6780         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6781 cd      write (iout,*) 'Processor',MyID,
6782 cd   & ' is receiving correlation contribution from processor',MyID+1,
6783 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6784 cd      write (*,*) 'Processor',MyID,
6785 cd   & ' is receiving correlation contribution from processor',MyID+1,
6786 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6787         nbytes=-1
6788         do while (nbytes.le.0)
6789           call mp_probe(MyID+1,CorrelType,nbytes)
6790         enddo
6791 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6792         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6793 cd      write (iout,*) 'Processor',MyID,
6794 cd   & ' has received correlation contribution from processor',MyID+1,
6795 cd   & ' msglen=',msglen,' nbytes=',nbytes
6796 cd      write (iout,*) 'The received BUFFER array:'
6797 cd      do i=1,max_cont
6798 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6799 cd      enddo
6800         if (msglen.eq.msglen1) then
6801           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6802         else if (msglen.eq.msglen2)  then
6803           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6804           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6805         else
6806           write (iout,*)
6807      & 'ERROR!!!! message length changed while processing correlations.'
6808           write (*,*)
6809      & 'ERROR!!!! message length changed while processing correlations.'
6810           call mp_stopall(Error)
6811         endif ! msglen.eq.msglen1
6812       endif ! MyRank.lt.fgProcs-1
6813       if (ldone) goto 30
6814       ldone=.true.
6815       goto 10
6816    30 continue
6817 #endif
6818       if (lprn) then
6819         write (iout,'(a)') 'Contact function values:'
6820         do i=nnt,nct-2
6821           write (iout,'(2i3,50(1x,i2,f5.2))')
6822      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6823      &    j=1,num_cont_hb(i))
6824         enddo
6825       endif
6826       ecorr=0.0D0
6827       ecorr5=0.0d0
6828       ecorr6=0.0d0
6829 C Remove the loop below after debugging !!!
6830       do i=nnt,nct
6831         do j=1,3
6832           gradcorr(j,i)=0.0D0
6833           gradxorr(j,i)=0.0D0
6834         enddo
6835       enddo
6836 C Calculate the dipole-dipole interaction energies
6837       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6838       do i=iatel_s,iatel_e+1
6839         num_conti=num_cont_hb(i)
6840         do jj=1,num_conti
6841           j=jcont_hb(jj,i)
6842           call dipole(i,j,jj)
6843         enddo
6844       enddo
6845       endif
6846 C Calculate the local-electrostatic correlation terms
6847       do i=iatel_s,iatel_e+1
6848         i1=i+1
6849         num_conti=num_cont_hb(i)
6850         num_conti1=num_cont_hb(i+1)
6851         do jj=1,num_conti
6852           j=jcont_hb(jj,i)
6853           do kk=1,num_conti1
6854             j1=jcont_hb(kk,i1)
6855 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6856 c     &         ' jj=',jj,' kk=',kk
6857             if (j1.eq.j+1 .or. j1.eq.j-1) then
6858 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6859 C The system gains extra energy.
6860               n_corr=n_corr+1
6861               sqd1=dsqrt(d_cont(jj,i))
6862               sqd2=dsqrt(d_cont(kk,i1))
6863               sred_geom = sqd1*sqd2
6864               IF (sred_geom.lt.cutoff_corr) THEN
6865                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6866      &            ekont,fprimcont)
6867 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6868 c     &         ' jj=',jj,' kk=',kk
6869                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6870                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6871                 do l=1,3
6872                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6873                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6874                 enddo
6875                 n_corr1=n_corr1+1
6876 cd               write (iout,*) 'sred_geom=',sred_geom,
6877 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6878                 call calc_eello(i,j,i+1,j1,jj,kk)
6879                 if (wcorr4.gt.0.0d0)
6880      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6881                 if (wcorr5.gt.0.0d0)
6882      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6883 c                print *,"wcorr5",ecorr5
6884 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6885 cd                write(2,*)'ijkl',i,j,i+1,j1
6886                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6887      &               .or. wturn6.eq.0.0d0))then
6888 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6889                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6890 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6891 cd     &            'ecorr6=',ecorr6
6892 cd                write (iout,'(4e15.5)') sred_geom,
6893 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6894 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6895 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6896                 else if (wturn6.gt.0.0d0
6897      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6898 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6899                   eturn6=eturn6+eello_turn6(i,jj,kk)
6900 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6901                 endif
6902               ENDIF
6903 1111          continue
6904             else if (j1.eq.j) then
6905 C Contacts I-J and I-(J+1) occur simultaneously.
6906 C The system loses extra energy.
6907 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6908             endif
6909           enddo ! kk
6910           do kk=1,num_conti
6911             j1=jcont_hb(kk,i)
6912 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6913 c    &         ' jj=',jj,' kk=',kk
6914             if (j1.eq.j+1) then
6915 C Contacts I-J and (I+1)-J occur simultaneously.
6916 C The system loses extra energy.
6917 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6918             endif ! j1==j+1
6919           enddo ! kk
6920         enddo ! jj
6921       enddo ! i
6922       return
6923       end
6924 c------------------------------------------------------------------------------
6925       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6926       implicit real*8 (a-h,o-z)
6927       include 'DIMENSIONS'
6928       include 'COMMON.IOUNITS'
6929       include 'COMMON.DERIV'
6930       include 'COMMON.INTERACT'
6931       include 'COMMON.CONTACTS'
6932       double precision gx(3),gx1(3)
6933       logical lprn
6934       lprn=.false.
6935       eij=facont_hb(jj,i)
6936       ekl=facont_hb(kk,k)
6937       ees0pij=ees0p(jj,i)
6938       ees0pkl=ees0p(kk,k)
6939       ees0mij=ees0m(jj,i)
6940       ees0mkl=ees0m(kk,k)
6941       ekont=eij*ekl
6942       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6943 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6944 C Following 4 lines for diagnostics.
6945 cd    ees0pkl=0.0D0
6946 cd    ees0pij=1.0D0
6947 cd    ees0mkl=0.0D0
6948 cd    ees0mij=1.0D0
6949 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6950 c    &   ' and',k,l
6951 c     write (iout,*)'Contacts have occurred for peptide groups',
6952 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6953 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6954 C Calculate the multi-body contribution to energy.
6955       ecorr=ecorr+ekont*ees
6956       if (calc_grad) then
6957 C Calculate multi-body contributions to the gradient.
6958       do ll=1,3
6959         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6960         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6961      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6962      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6963         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6964      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6965      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6966         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6967         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6968      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6969      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6970         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6971      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6972      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6973       enddo
6974       do m=i+1,j-1
6975         do ll=1,3
6976           gradcorr(ll,m)=gradcorr(ll,m)+
6977      &     ees*ekl*gacont_hbr(ll,jj,i)-
6978      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6979      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6980         enddo
6981       enddo
6982       do m=k+1,l-1
6983         do ll=1,3
6984           gradcorr(ll,m)=gradcorr(ll,m)+
6985      &     ees*eij*gacont_hbr(ll,kk,k)-
6986      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6987      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6988         enddo
6989       enddo
6990       endif
6991       ehbcorr=ekont*ees
6992       return
6993       end
6994 C---------------------------------------------------------------------------
6995       subroutine dipole(i,j,jj)
6996       implicit real*8 (a-h,o-z)
6997       include 'DIMENSIONS'
6998       include 'DIMENSIONS.ZSCOPT'
6999       include 'COMMON.IOUNITS'
7000       include 'COMMON.CHAIN'
7001       include 'COMMON.FFIELD'
7002       include 'COMMON.DERIV'
7003       include 'COMMON.INTERACT'
7004       include 'COMMON.CONTACTS'
7005       include 'COMMON.TORSION'
7006       include 'COMMON.VAR'
7007       include 'COMMON.GEO'
7008       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7009      &  auxmat(2,2)
7010       iti1 = itortyp(itype(i+1))
7011       if (j.lt.nres-1) then
7012         itj1 = itortyp(itype(j+1))
7013       else
7014         itj1=ntortyp+1
7015       endif
7016       do iii=1,2
7017         dipi(iii,1)=Ub2(iii,i)
7018         dipderi(iii)=Ub2der(iii,i)
7019         dipi(iii,2)=b1(iii,iti1)
7020         dipj(iii,1)=Ub2(iii,j)
7021         dipderj(iii)=Ub2der(iii,j)
7022         dipj(iii,2)=b1(iii,itj1)
7023       enddo
7024       kkk=0
7025       do iii=1,2
7026         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7027         do jjj=1,2
7028           kkk=kkk+1
7029           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7030         enddo
7031       enddo
7032       if (.not.calc_grad) return
7033       do kkk=1,5
7034         do lll=1,3
7035           mmm=0
7036           do iii=1,2
7037             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7038      &        auxvec(1))
7039             do jjj=1,2
7040               mmm=mmm+1
7041               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7042             enddo
7043           enddo
7044         enddo
7045       enddo
7046       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7047       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7048       do iii=1,2
7049         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7050       enddo
7051       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7052       do iii=1,2
7053         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7054       enddo
7055       return
7056       end
7057 C---------------------------------------------------------------------------
7058       subroutine calc_eello(i,j,k,l,jj,kk)
7059 C
7060 C This subroutine computes matrices and vectors needed to calculate
7061 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7062 C
7063       implicit real*8 (a-h,o-z)
7064       include 'DIMENSIONS'
7065       include 'DIMENSIONS.ZSCOPT'
7066       include 'COMMON.IOUNITS'
7067       include 'COMMON.CHAIN'
7068       include 'COMMON.DERIV'
7069       include 'COMMON.INTERACT'
7070       include 'COMMON.CONTACTS'
7071       include 'COMMON.TORSION'
7072       include 'COMMON.VAR'
7073       include 'COMMON.GEO'
7074       include 'COMMON.FFIELD'
7075       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7076      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7077       logical lprn
7078       common /kutas/ lprn
7079 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7080 cd     & ' jj=',jj,' kk=',kk
7081 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7082       do iii=1,2
7083         do jjj=1,2
7084           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7085           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7086         enddo
7087       enddo
7088       call transpose2(aa1(1,1),aa1t(1,1))
7089       call transpose2(aa2(1,1),aa2t(1,1))
7090       do kkk=1,5
7091         do lll=1,3
7092           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7093      &      aa1tder(1,1,lll,kkk))
7094           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7095      &      aa2tder(1,1,lll,kkk))
7096         enddo
7097       enddo
7098       if (l.eq.j+1) then
7099 C parallel orientation of the two CA-CA-CA frames.
7100         if (i.gt.1) then
7101           iti=itortyp(itype(i))
7102         else
7103           iti=ntortyp+1
7104         endif
7105         itk1=itortyp(itype(k+1))
7106         itj=itortyp(itype(j))
7107         if (l.lt.nres-1) then
7108           itl1=itortyp(itype(l+1))
7109         else
7110           itl1=ntortyp+1
7111         endif
7112 C A1 kernel(j+1) A2T
7113 cd        do iii=1,2
7114 cd          write (iout,'(3f10.5,5x,3f10.5)')
7115 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7116 cd        enddo
7117         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7118      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7119      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7120 C Following matrices are needed only for 6-th order cumulants
7121         IF (wcorr6.gt.0.0d0) THEN
7122         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7123      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7124      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7125         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7126      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7127      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7128      &   ADtEAderx(1,1,1,1,1,1))
7129         lprn=.false.
7130         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7131      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7132      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7133      &   ADtEA1derx(1,1,1,1,1,1))
7134         ENDIF
7135 C End 6-th order cumulants
7136 cd        lprn=.false.
7137 cd        if (lprn) then
7138 cd        write (2,*) 'In calc_eello6'
7139 cd        do iii=1,2
7140 cd          write (2,*) 'iii=',iii
7141 cd          do kkk=1,5
7142 cd            write (2,*) 'kkk=',kkk
7143 cd            do jjj=1,2
7144 cd              write (2,'(3(2f10.5),5x)')
7145 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7146 cd            enddo
7147 cd          enddo
7148 cd        enddo
7149 cd        endif
7150         call transpose2(EUgder(1,1,k),auxmat(1,1))
7151         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7152         call transpose2(EUg(1,1,k),auxmat(1,1))
7153         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7154         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7155         do iii=1,2
7156           do kkk=1,5
7157             do lll=1,3
7158               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7159      &          EAEAderx(1,1,lll,kkk,iii,1))
7160             enddo
7161           enddo
7162         enddo
7163 C A1T kernel(i+1) A2
7164         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7165      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7166      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7167 C Following matrices are needed only for 6-th order cumulants
7168         IF (wcorr6.gt.0.0d0) THEN
7169         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7170      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7171      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7172         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7173      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7174      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7175      &   ADtEAderx(1,1,1,1,1,2))
7176         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7177      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7178      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7179      &   ADtEA1derx(1,1,1,1,1,2))
7180         ENDIF
7181 C End 6-th order cumulants
7182         call transpose2(EUgder(1,1,l),auxmat(1,1))
7183         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7184         call transpose2(EUg(1,1,l),auxmat(1,1))
7185         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7186         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7187         do iii=1,2
7188           do kkk=1,5
7189             do lll=1,3
7190               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7191      &          EAEAderx(1,1,lll,kkk,iii,2))
7192             enddo
7193           enddo
7194         enddo
7195 C AEAb1 and AEAb2
7196 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7197 C They are needed only when the fifth- or the sixth-order cumulants are
7198 C indluded.
7199         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7200         call transpose2(AEA(1,1,1),auxmat(1,1))
7201         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7202         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7203         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7204         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7205         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7206         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7207         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7208         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7209         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7210         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7211         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7212         call transpose2(AEA(1,1,2),auxmat(1,1))
7213         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7214         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7215         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7216         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7217         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7218         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7219         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7220         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7221         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7222         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7223         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7224 C Calculate the Cartesian derivatives of the vectors.
7225         do iii=1,2
7226           do kkk=1,5
7227             do lll=1,3
7228               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7229               call matvec2(auxmat(1,1),b1(1,iti),
7230      &          AEAb1derx(1,lll,kkk,iii,1,1))
7231               call matvec2(auxmat(1,1),Ub2(1,i),
7232      &          AEAb2derx(1,lll,kkk,iii,1,1))
7233               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7234      &          AEAb1derx(1,lll,kkk,iii,2,1))
7235               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7236      &          AEAb2derx(1,lll,kkk,iii,2,1))
7237               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7238               call matvec2(auxmat(1,1),b1(1,itj),
7239      &          AEAb1derx(1,lll,kkk,iii,1,2))
7240               call matvec2(auxmat(1,1),Ub2(1,j),
7241      &          AEAb2derx(1,lll,kkk,iii,1,2))
7242               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7243      &          AEAb1derx(1,lll,kkk,iii,2,2))
7244               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7245      &          AEAb2derx(1,lll,kkk,iii,2,2))
7246             enddo
7247           enddo
7248         enddo
7249         ENDIF
7250 C End vectors
7251       else
7252 C Antiparallel orientation of the two CA-CA-CA frames.
7253         if (i.gt.1) then
7254           iti=itortyp(itype(i))
7255         else
7256           iti=ntortyp+1
7257         endif
7258         itk1=itortyp(itype(k+1))
7259         itl=itortyp(itype(l))
7260         itj=itortyp(itype(j))
7261         if (j.lt.nres-1) then
7262           itj1=itortyp(itype(j+1))
7263         else
7264           itj1=ntortyp+1
7265         endif
7266 C A2 kernel(j-1)T A1T
7267         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7268      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7269      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7270 C Following matrices are needed only for 6-th order cumulants
7271         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7272      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7273         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7274      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7275      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7276         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7277      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7278      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7279      &   ADtEAderx(1,1,1,1,1,1))
7280         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7281      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7282      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7283      &   ADtEA1derx(1,1,1,1,1,1))
7284         ENDIF
7285 C End 6-th order cumulants
7286         call transpose2(EUgder(1,1,k),auxmat(1,1))
7287         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7288         call transpose2(EUg(1,1,k),auxmat(1,1))
7289         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7290         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7291         do iii=1,2
7292           do kkk=1,5
7293             do lll=1,3
7294               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7295      &          EAEAderx(1,1,lll,kkk,iii,1))
7296             enddo
7297           enddo
7298         enddo
7299 C A2T kernel(i+1)T A1
7300         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7301      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7302      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7303 C Following matrices are needed only for 6-th order cumulants
7304         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7305      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7306         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7307      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7308      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7309         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7310      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7311      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7312      &   ADtEAderx(1,1,1,1,1,2))
7313         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7314      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7315      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7316      &   ADtEA1derx(1,1,1,1,1,2))
7317         ENDIF
7318 C End 6-th order cumulants
7319         call transpose2(EUgder(1,1,j),auxmat(1,1))
7320         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7321         call transpose2(EUg(1,1,j),auxmat(1,1))
7322         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7323         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7324         do iii=1,2
7325           do kkk=1,5
7326             do lll=1,3
7327               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7328      &          EAEAderx(1,1,lll,kkk,iii,2))
7329             enddo
7330           enddo
7331         enddo
7332 C AEAb1 and AEAb2
7333 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7334 C They are needed only when the fifth- or the sixth-order cumulants are
7335 C indluded.
7336         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7337      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7338         call transpose2(AEA(1,1,1),auxmat(1,1))
7339         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7340         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7341         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7342         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7343         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7344         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7345         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7346         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7347         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7348         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7349         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7350         call transpose2(AEA(1,1,2),auxmat(1,1))
7351         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7352         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7353         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7354         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7355         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7356         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7357         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7358         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7359         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7360         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7361         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7362 C Calculate the Cartesian derivatives of the vectors.
7363         do iii=1,2
7364           do kkk=1,5
7365             do lll=1,3
7366               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7367               call matvec2(auxmat(1,1),b1(1,iti),
7368      &          AEAb1derx(1,lll,kkk,iii,1,1))
7369               call matvec2(auxmat(1,1),Ub2(1,i),
7370      &          AEAb2derx(1,lll,kkk,iii,1,1))
7371               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7372      &          AEAb1derx(1,lll,kkk,iii,2,1))
7373               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7374      &          AEAb2derx(1,lll,kkk,iii,2,1))
7375               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7376               call matvec2(auxmat(1,1),b1(1,itl),
7377      &          AEAb1derx(1,lll,kkk,iii,1,2))
7378               call matvec2(auxmat(1,1),Ub2(1,l),
7379      &          AEAb2derx(1,lll,kkk,iii,1,2))
7380               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7381      &          AEAb1derx(1,lll,kkk,iii,2,2))
7382               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7383      &          AEAb2derx(1,lll,kkk,iii,2,2))
7384             enddo
7385           enddo
7386         enddo
7387         ENDIF
7388 C End vectors
7389       endif
7390       return
7391       end
7392 C---------------------------------------------------------------------------
7393       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7394      &  KK,KKderg,AKA,AKAderg,AKAderx)
7395       implicit none
7396       integer nderg
7397       logical transp
7398       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7399      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7400      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7401       integer iii,kkk,lll
7402       integer jjj,mmm
7403       logical lprn
7404       common /kutas/ lprn
7405       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7406       do iii=1,nderg
7407         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7408      &    AKAderg(1,1,iii))
7409       enddo
7410 cd      if (lprn) write (2,*) 'In kernel'
7411       do kkk=1,5
7412 cd        if (lprn) write (2,*) 'kkk=',kkk
7413         do lll=1,3
7414           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7415      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7416 cd          if (lprn) then
7417 cd            write (2,*) 'lll=',lll
7418 cd            write (2,*) 'iii=1'
7419 cd            do jjj=1,2
7420 cd              write (2,'(3(2f10.5),5x)')
7421 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7422 cd            enddo
7423 cd          endif
7424           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7425      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7426 cd          if (lprn) then
7427 cd            write (2,*) 'lll=',lll
7428 cd            write (2,*) 'iii=2'
7429 cd            do jjj=1,2
7430 cd              write (2,'(3(2f10.5),5x)')
7431 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7432 cd            enddo
7433 cd          endif
7434         enddo
7435       enddo
7436       return
7437       end
7438 C---------------------------------------------------------------------------
7439       double precision function eello4(i,j,k,l,jj,kk)
7440       implicit real*8 (a-h,o-z)
7441       include 'DIMENSIONS'
7442       include 'DIMENSIONS.ZSCOPT'
7443       include 'COMMON.IOUNITS'
7444       include 'COMMON.CHAIN'
7445       include 'COMMON.DERIV'
7446       include 'COMMON.INTERACT'
7447       include 'COMMON.CONTACTS'
7448       include 'COMMON.TORSION'
7449       include 'COMMON.VAR'
7450       include 'COMMON.GEO'
7451       double precision pizda(2,2),ggg1(3),ggg2(3)
7452 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7453 cd        eello4=0.0d0
7454 cd        return
7455 cd      endif
7456 cd      print *,'eello4:',i,j,k,l,jj,kk
7457 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7458 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7459 cold      eij=facont_hb(jj,i)
7460 cold      ekl=facont_hb(kk,k)
7461 cold      ekont=eij*ekl
7462       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7463       if (calc_grad) then
7464 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7465       gcorr_loc(k-1)=gcorr_loc(k-1)
7466      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7467       if (l.eq.j+1) then
7468         gcorr_loc(l-1)=gcorr_loc(l-1)
7469      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7470       else
7471         gcorr_loc(j-1)=gcorr_loc(j-1)
7472      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7473       endif
7474       do iii=1,2
7475         do kkk=1,5
7476           do lll=1,3
7477             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7478      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7479 cd            derx(lll,kkk,iii)=0.0d0
7480           enddo
7481         enddo
7482       enddo
7483 cd      gcorr_loc(l-1)=0.0d0
7484 cd      gcorr_loc(j-1)=0.0d0
7485 cd      gcorr_loc(k-1)=0.0d0
7486 cd      eel4=1.0d0
7487 cd      write (iout,*)'Contacts have occurred for peptide groups',
7488 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7489 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7490       if (j.lt.nres-1) then
7491         j1=j+1
7492         j2=j-1
7493       else
7494         j1=j-1
7495         j2=j-2
7496       endif
7497       if (l.lt.nres-1) then
7498         l1=l+1
7499         l2=l-1
7500       else
7501         l1=l-1
7502         l2=l-2
7503       endif
7504       do ll=1,3
7505 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
7506         ggg1(ll)=eel4*g_contij(ll,1)
7507         ggg2(ll)=eel4*g_contij(ll,2)
7508         ghalf=0.5d0*ggg1(ll)
7509 cd        ghalf=0.0d0
7510         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
7511         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7512         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
7513         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7514 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
7515         ghalf=0.5d0*ggg2(ll)
7516 cd        ghalf=0.0d0
7517         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
7518         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7519         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
7520         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7521       enddo
7522 cd      goto 1112
7523       do m=i+1,j-1
7524         do ll=1,3
7525 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
7526           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7527         enddo
7528       enddo
7529       do m=k+1,l-1
7530         do ll=1,3
7531 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
7532           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7533         enddo
7534       enddo
7535 1112  continue
7536       do m=i+2,j2
7537         do ll=1,3
7538           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7539         enddo
7540       enddo
7541       do m=k+2,l2
7542         do ll=1,3
7543           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7544         enddo
7545       enddo
7546 cd      do iii=1,nres-3
7547 cd        write (2,*) iii,gcorr_loc(iii)
7548 cd      enddo
7549       endif
7550       eello4=ekont*eel4
7551 cd      write (2,*) 'ekont',ekont
7552 cd      write (iout,*) 'eello4',ekont*eel4
7553       return
7554       end
7555 C---------------------------------------------------------------------------
7556       double precision function eello5(i,j,k,l,jj,kk)
7557       implicit real*8 (a-h,o-z)
7558       include 'DIMENSIONS'
7559       include 'DIMENSIONS.ZSCOPT'
7560       include 'COMMON.IOUNITS'
7561       include 'COMMON.CHAIN'
7562       include 'COMMON.DERIV'
7563       include 'COMMON.INTERACT'
7564       include 'COMMON.CONTACTS'
7565       include 'COMMON.TORSION'
7566       include 'COMMON.VAR'
7567       include 'COMMON.GEO'
7568       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7569       double precision ggg1(3),ggg2(3)
7570 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7571 C                                                                              C
7572 C                            Parallel chains                                   C
7573 C                                                                              C
7574 C          o             o                   o             o                   C
7575 C         /l\           / \             \   / \           / \   /              C
7576 C        /   \         /   \             \ /   \         /   \ /               C
7577 C       j| o |l1       | o |              o| o |         | o |o                C
7578 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7579 C      \i/   \         /   \ /             /   \         /   \                 C
7580 C       o    k1             o                                                  C
7581 C         (I)          (II)                (III)          (IV)                 C
7582 C                                                                              C
7583 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7584 C                                                                              C
7585 C                            Antiparallel chains                               C
7586 C                                                                              C
7587 C          o             o                   o             o                   C
7588 C         /j\           / \             \   / \           / \   /              C
7589 C        /   \         /   \             \ /   \         /   \ /               C
7590 C      j1| o |l        | o |              o| o |         | o |o                C
7591 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7592 C      \i/   \         /   \ /             /   \         /   \                 C
7593 C       o     k1            o                                                  C
7594 C         (I)          (II)                (III)          (IV)                 C
7595 C                                                                              C
7596 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7597 C                                                                              C
7598 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7599 C                                                                              C
7600 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7601 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7602 cd        eello5=0.0d0
7603 cd        return
7604 cd      endif
7605 cd      write (iout,*)
7606 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7607 cd     &   ' and',k,l
7608       itk=itortyp(itype(k))
7609       itl=itortyp(itype(l))
7610       itj=itortyp(itype(j))
7611       eello5_1=0.0d0
7612       eello5_2=0.0d0
7613       eello5_3=0.0d0
7614       eello5_4=0.0d0
7615 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7616 cd     &   eel5_3_num,eel5_4_num)
7617       do iii=1,2
7618         do kkk=1,5
7619           do lll=1,3
7620             derx(lll,kkk,iii)=0.0d0
7621           enddo
7622         enddo
7623       enddo
7624 cd      eij=facont_hb(jj,i)
7625 cd      ekl=facont_hb(kk,k)
7626 cd      ekont=eij*ekl
7627 cd      write (iout,*)'Contacts have occurred for peptide groups',
7628 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7629 cd      goto 1111
7630 C Contribution from the graph I.
7631 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7632 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7633       call transpose2(EUg(1,1,k),auxmat(1,1))
7634       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7635       vv(1)=pizda(1,1)-pizda(2,2)
7636       vv(2)=pizda(1,2)+pizda(2,1)
7637       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7638      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7639       if (calc_grad) then
7640 C Explicit gradient in virtual-dihedral angles.
7641       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7642      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7643      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7644       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7645       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7646       vv(1)=pizda(1,1)-pizda(2,2)
7647       vv(2)=pizda(1,2)+pizda(2,1)
7648       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7649      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7650      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7651       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7652       vv(1)=pizda(1,1)-pizda(2,2)
7653       vv(2)=pizda(1,2)+pizda(2,1)
7654       if (l.eq.j+1) then
7655         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7656      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7657      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7658       else
7659         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7660      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7661      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7662       endif
7663 C Cartesian gradient
7664       do iii=1,2
7665         do kkk=1,5
7666           do lll=1,3
7667             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7668      &        pizda(1,1))
7669             vv(1)=pizda(1,1)-pizda(2,2)
7670             vv(2)=pizda(1,2)+pizda(2,1)
7671             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7672      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7673      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7674           enddo
7675         enddo
7676       enddo
7677 c      goto 1112
7678       endif
7679 c1111  continue
7680 C Contribution from graph II
7681       call transpose2(EE(1,1,itk),auxmat(1,1))
7682       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7683       vv(1)=pizda(1,1)+pizda(2,2)
7684       vv(2)=pizda(2,1)-pizda(1,2)
7685       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7686      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7687       if (calc_grad) then
7688 C Explicit gradient in virtual-dihedral angles.
7689       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7690      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7691       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7692       vv(1)=pizda(1,1)+pizda(2,2)
7693       vv(2)=pizda(2,1)-pizda(1,2)
7694       if (l.eq.j+1) then
7695         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7696      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7697      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7698       else
7699         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7700      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7701      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7702       endif
7703 C Cartesian gradient
7704       do iii=1,2
7705         do kkk=1,5
7706           do lll=1,3
7707             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7708      &        pizda(1,1))
7709             vv(1)=pizda(1,1)+pizda(2,2)
7710             vv(2)=pizda(2,1)-pizda(1,2)
7711             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7712      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7713      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7714           enddo
7715         enddo
7716       enddo
7717 cd      goto 1112
7718       endif
7719 cd1111  continue
7720       if (l.eq.j+1) then
7721 cd        goto 1110
7722 C Parallel orientation
7723 C Contribution from graph III
7724         call transpose2(EUg(1,1,l),auxmat(1,1))
7725         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7726         vv(1)=pizda(1,1)-pizda(2,2)
7727         vv(2)=pizda(1,2)+pizda(2,1)
7728         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7729      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7730         if (calc_grad) then
7731 C Explicit gradient in virtual-dihedral angles.
7732         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7733      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7734      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7735         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7736         vv(1)=pizda(1,1)-pizda(2,2)
7737         vv(2)=pizda(1,2)+pizda(2,1)
7738         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7739      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7740      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7741         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7742         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7743         vv(1)=pizda(1,1)-pizda(2,2)
7744         vv(2)=pizda(1,2)+pizda(2,1)
7745         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7746      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7747      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7748 C Cartesian gradient
7749         do iii=1,2
7750           do kkk=1,5
7751             do lll=1,3
7752               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7753      &          pizda(1,1))
7754               vv(1)=pizda(1,1)-pizda(2,2)
7755               vv(2)=pizda(1,2)+pizda(2,1)
7756               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7757      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7758      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7759             enddo
7760           enddo
7761         enddo
7762 cd        goto 1112
7763         endif
7764 C Contribution from graph IV
7765 cd1110    continue
7766         call transpose2(EE(1,1,itl),auxmat(1,1))
7767         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7768         vv(1)=pizda(1,1)+pizda(2,2)
7769         vv(2)=pizda(2,1)-pizda(1,2)
7770         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7771      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7772         if (calc_grad) then
7773 C Explicit gradient in virtual-dihedral angles.
7774         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7775      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7776         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7777         vv(1)=pizda(1,1)+pizda(2,2)
7778         vv(2)=pizda(2,1)-pizda(1,2)
7779         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7780      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7781      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7782 C Cartesian gradient
7783         do iii=1,2
7784           do kkk=1,5
7785             do lll=1,3
7786               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7787      &          pizda(1,1))
7788               vv(1)=pizda(1,1)+pizda(2,2)
7789               vv(2)=pizda(2,1)-pizda(1,2)
7790               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7791      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7792      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7793             enddo
7794           enddo
7795         enddo
7796         endif
7797       else
7798 C Antiparallel orientation
7799 C Contribution from graph III
7800 c        goto 1110
7801         call transpose2(EUg(1,1,j),auxmat(1,1))
7802         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7803         vv(1)=pizda(1,1)-pizda(2,2)
7804         vv(2)=pizda(1,2)+pizda(2,1)
7805         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7806      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7807         if (calc_grad) then
7808 C Explicit gradient in virtual-dihedral angles.
7809         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7810      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7811      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7812         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7813         vv(1)=pizda(1,1)-pizda(2,2)
7814         vv(2)=pizda(1,2)+pizda(2,1)
7815         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7816      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7817      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7818         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7819         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7820         vv(1)=pizda(1,1)-pizda(2,2)
7821         vv(2)=pizda(1,2)+pizda(2,1)
7822         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7823      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7824      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7825 C Cartesian gradient
7826         do iii=1,2
7827           do kkk=1,5
7828             do lll=1,3
7829               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7830      &          pizda(1,1))
7831               vv(1)=pizda(1,1)-pizda(2,2)
7832               vv(2)=pizda(1,2)+pizda(2,1)
7833               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7834      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7835      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7836             enddo
7837           enddo
7838         enddo
7839 cd        goto 1112
7840         endif
7841 C Contribution from graph IV
7842 1110    continue
7843         call transpose2(EE(1,1,itj),auxmat(1,1))
7844         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7845         vv(1)=pizda(1,1)+pizda(2,2)
7846         vv(2)=pizda(2,1)-pizda(1,2)
7847         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7848      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7849         if (calc_grad) then
7850 C Explicit gradient in virtual-dihedral angles.
7851         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7852      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7853         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7854         vv(1)=pizda(1,1)+pizda(2,2)
7855         vv(2)=pizda(2,1)-pizda(1,2)
7856         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7857      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7858      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7859 C Cartesian gradient
7860         do iii=1,2
7861           do kkk=1,5
7862             do lll=1,3
7863               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7864      &          pizda(1,1))
7865               vv(1)=pizda(1,1)+pizda(2,2)
7866               vv(2)=pizda(2,1)-pizda(1,2)
7867               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7868      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7869      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7870             enddo
7871           enddo
7872         enddo
7873       endif
7874       endif
7875 1112  continue
7876       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7877 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7878 cd        write (2,*) 'ijkl',i,j,k,l
7879 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7880 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7881 cd      endif
7882 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7883 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7884 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7885 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7886       if (calc_grad) then
7887       if (j.lt.nres-1) then
7888         j1=j+1
7889         j2=j-1
7890       else
7891         j1=j-1
7892         j2=j-2
7893       endif
7894       if (l.lt.nres-1) then
7895         l1=l+1
7896         l2=l-1
7897       else
7898         l1=l-1
7899         l2=l-2
7900       endif
7901 cd      eij=1.0d0
7902 cd      ekl=1.0d0
7903 cd      ekont=1.0d0
7904 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7905       do ll=1,3
7906         ggg1(ll)=eel5*g_contij(ll,1)
7907         ggg2(ll)=eel5*g_contij(ll,2)
7908 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7909         ghalf=0.5d0*ggg1(ll)
7910 cd        ghalf=0.0d0
7911         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7912         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7913         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7914         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7915 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7916         ghalf=0.5d0*ggg2(ll)
7917 cd        ghalf=0.0d0
7918         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7919         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7920         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7921         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7922       enddo
7923 cd      goto 1112
7924       do m=i+1,j-1
7925         do ll=1,3
7926 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7927           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7928         enddo
7929       enddo
7930       do m=k+1,l-1
7931         do ll=1,3
7932 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7933           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7934         enddo
7935       enddo
7936 c1112  continue
7937       do m=i+2,j2
7938         do ll=1,3
7939           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7940         enddo
7941       enddo
7942       do m=k+2,l2
7943         do ll=1,3
7944           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7945         enddo
7946       enddo
7947 cd      do iii=1,nres-3
7948 cd        write (2,*) iii,g_corr5_loc(iii)
7949 cd      enddo
7950       endif
7951       eello5=ekont*eel5
7952 cd      write (2,*) 'ekont',ekont
7953 cd      write (iout,*) 'eello5',ekont*eel5
7954       return
7955       end
7956 c--------------------------------------------------------------------------
7957       double precision function eello6(i,j,k,l,jj,kk)
7958       implicit real*8 (a-h,o-z)
7959       include 'DIMENSIONS'
7960       include 'DIMENSIONS.ZSCOPT'
7961       include 'COMMON.IOUNITS'
7962       include 'COMMON.CHAIN'
7963       include 'COMMON.DERIV'
7964       include 'COMMON.INTERACT'
7965       include 'COMMON.CONTACTS'
7966       include 'COMMON.TORSION'
7967       include 'COMMON.VAR'
7968       include 'COMMON.GEO'
7969       include 'COMMON.FFIELD'
7970       double precision ggg1(3),ggg2(3)
7971 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7972 cd        eello6=0.0d0
7973 cd        return
7974 cd      endif
7975 cd      write (iout,*)
7976 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7977 cd     &   ' and',k,l
7978       eello6_1=0.0d0
7979       eello6_2=0.0d0
7980       eello6_3=0.0d0
7981       eello6_4=0.0d0
7982       eello6_5=0.0d0
7983       eello6_6=0.0d0
7984 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7985 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7986       do iii=1,2
7987         do kkk=1,5
7988           do lll=1,3
7989             derx(lll,kkk,iii)=0.0d0
7990           enddo
7991         enddo
7992       enddo
7993 cd      eij=facont_hb(jj,i)
7994 cd      ekl=facont_hb(kk,k)
7995 cd      ekont=eij*ekl
7996 cd      eij=1.0d0
7997 cd      ekl=1.0d0
7998 cd      ekont=1.0d0
7999       if (l.eq.j+1) then
8000         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8001         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8002         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8003         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8004         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8005         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8006       else
8007         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8008         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8009         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8010         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8011         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8012           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8013         else
8014           eello6_5=0.0d0
8015         endif
8016         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8017       endif
8018 C If turn contributions are considered, they will be handled separately.
8019       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8020 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
8021 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
8022 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
8023 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
8024 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
8025 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
8026 cd      goto 1112
8027       if (calc_grad) then
8028       if (j.lt.nres-1) then
8029         j1=j+1
8030         j2=j-1
8031       else
8032         j1=j-1
8033         j2=j-2
8034       endif
8035       if (l.lt.nres-1) then
8036         l1=l+1
8037         l2=l-1
8038       else
8039         l1=l-1
8040         l2=l-2
8041       endif
8042       do ll=1,3
8043         ggg1(ll)=eel6*g_contij(ll,1)
8044         ggg2(ll)=eel6*g_contij(ll,2)
8045 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8046         ghalf=0.5d0*ggg1(ll)
8047 cd        ghalf=0.0d0
8048         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
8049         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8050         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
8051         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8052         ghalf=0.5d0*ggg2(ll)
8053 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8054 cd        ghalf=0.0d0
8055         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
8056         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8057         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
8058         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8059       enddo
8060 cd      goto 1112
8061       do m=i+1,j-1
8062         do ll=1,3
8063 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8064           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8065         enddo
8066       enddo
8067       do m=k+1,l-1
8068         do ll=1,3
8069 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8070           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8071         enddo
8072       enddo
8073 1112  continue
8074       do m=i+2,j2
8075         do ll=1,3
8076           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8077         enddo
8078       enddo
8079       do m=k+2,l2
8080         do ll=1,3
8081           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8082         enddo
8083       enddo
8084 cd      do iii=1,nres-3
8085 cd        write (2,*) iii,g_corr6_loc(iii)
8086 cd      enddo
8087       endif
8088       eello6=ekont*eel6
8089 cd      write (2,*) 'ekont',ekont
8090 cd      write (iout,*) 'eello6',ekont*eel6
8091       return
8092       end
8093 c--------------------------------------------------------------------------
8094       double precision function eello6_graph1(i,j,k,l,imat,swap)
8095       implicit real*8 (a-h,o-z)
8096       include 'DIMENSIONS'
8097       include 'DIMENSIONS.ZSCOPT'
8098       include 'COMMON.IOUNITS'
8099       include 'COMMON.CHAIN'
8100       include 'COMMON.DERIV'
8101       include 'COMMON.INTERACT'
8102       include 'COMMON.CONTACTS'
8103       include 'COMMON.TORSION'
8104       include 'COMMON.VAR'
8105       include 'COMMON.GEO'
8106       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8107       logical swap
8108       logical lprn
8109       common /kutas/ lprn
8110 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8111 C                                                                              C
8112 C      Parallel       Antiparallel                                             C
8113 C                                                                              C
8114 C          o             o                                                     C
8115 C         /l\           /j\                                                    C
8116 C        /   \         /   \                                                   C
8117 C       /| o |         | o |\                                                  C
8118 C     \ j|/k\|  /   \  |/k\|l /                                                C
8119 C      \ /   \ /     \ /   \ /                                                 C
8120 C       o     o       o     o                                                  C
8121 C       i             i                                                        C
8122 C                                                                              C
8123 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8124       itk=itortyp(itype(k))
8125       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8126       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8127       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8128       call transpose2(EUgC(1,1,k),auxmat(1,1))
8129       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8130       vv1(1)=pizda1(1,1)-pizda1(2,2)
8131       vv1(2)=pizda1(1,2)+pizda1(2,1)
8132       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8133       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8134       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8135       s5=scalar2(vv(1),Dtobr2(1,i))
8136 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8137       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8138       if (.not. calc_grad) return
8139       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8140      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8141      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8142      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8143      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8144      & +scalar2(vv(1),Dtobr2der(1,i)))
8145       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8146       vv1(1)=pizda1(1,1)-pizda1(2,2)
8147       vv1(2)=pizda1(1,2)+pizda1(2,1)
8148       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8149       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8150       if (l.eq.j+1) then
8151         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8152      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8153      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8154      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8155      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8156       else
8157         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8158      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8159      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8160      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8161      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8162       endif
8163       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8164       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8165       vv1(1)=pizda1(1,1)-pizda1(2,2)
8166       vv1(2)=pizda1(1,2)+pizda1(2,1)
8167       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8168      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8169      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8170      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8171       do iii=1,2
8172         if (swap) then
8173           ind=3-iii
8174         else
8175           ind=iii
8176         endif
8177         do kkk=1,5
8178           do lll=1,3
8179             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8180             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8181             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8182             call transpose2(EUgC(1,1,k),auxmat(1,1))
8183             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8184      &        pizda1(1,1))
8185             vv1(1)=pizda1(1,1)-pizda1(2,2)
8186             vv1(2)=pizda1(1,2)+pizda1(2,1)
8187             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8188             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8189      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8190             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8191      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8192             s5=scalar2(vv(1),Dtobr2(1,i))
8193             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8194           enddo
8195         enddo
8196       enddo
8197       return
8198       end
8199 c----------------------------------------------------------------------------
8200       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8201       implicit real*8 (a-h,o-z)
8202       include 'DIMENSIONS'
8203       include 'DIMENSIONS.ZSCOPT'
8204       include 'COMMON.IOUNITS'
8205       include 'COMMON.CHAIN'
8206       include 'COMMON.DERIV'
8207       include 'COMMON.INTERACT'
8208       include 'COMMON.CONTACTS'
8209       include 'COMMON.TORSION'
8210       include 'COMMON.VAR'
8211       include 'COMMON.GEO'
8212       logical swap
8213       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8214      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8215       logical lprn
8216       common /kutas/ lprn
8217 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8218 C                                                                              C
8219 C      Parallel       Antiparallel                                             C
8220 C                                                                              C
8221 C          o             o                                                     C
8222 C     \   /l\           /j\   /                                                C
8223 C      \ /   \         /   \ /                                                 C
8224 C       o| o |         | o |o                                                  C
8225 C     \ j|/k\|      \  |/k\|l                                                  C
8226 C      \ /   \       \ /   \                                                   C
8227 C       o             o                                                        C
8228 C       i             i                                                        C
8229 C                                                                              C
8230 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8231 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8232 C AL 7/4/01 s1 would occur in the sixth-order moment,
8233 C           but not in a cluster cumulant
8234 #ifdef MOMENT
8235       s1=dip(1,jj,i)*dip(1,kk,k)
8236 #endif
8237       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8238       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8239       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8240       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8241       call transpose2(EUg(1,1,k),auxmat(1,1))
8242       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8243       vv(1)=pizda(1,1)-pizda(2,2)
8244       vv(2)=pizda(1,2)+pizda(2,1)
8245       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8246 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8247 #ifdef MOMENT
8248       eello6_graph2=-(s1+s2+s3+s4)
8249 #else
8250       eello6_graph2=-(s2+s3+s4)
8251 #endif
8252 c      eello6_graph2=-s3
8253       if (.not. calc_grad) return
8254 C Derivatives in gamma(i-1)
8255       if (i.gt.1) then
8256 #ifdef MOMENT
8257         s1=dipderg(1,jj,i)*dip(1,kk,k)
8258 #endif
8259         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8260         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8261         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8262         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8263 #ifdef MOMENT
8264         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8265 #else
8266         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8267 #endif
8268 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8269       endif
8270 C Derivatives in gamma(k-1)
8271 #ifdef MOMENT
8272       s1=dip(1,jj,i)*dipderg(1,kk,k)
8273 #endif
8274       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8275       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8276       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8277       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8278       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8279       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8280       vv(1)=pizda(1,1)-pizda(2,2)
8281       vv(2)=pizda(1,2)+pizda(2,1)
8282       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8283 #ifdef MOMENT
8284       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8285 #else
8286       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8287 #endif
8288 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8289 C Derivatives in gamma(j-1) or gamma(l-1)
8290       if (j.gt.1) then
8291 #ifdef MOMENT
8292         s1=dipderg(3,jj,i)*dip(1,kk,k)
8293 #endif
8294         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8295         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8296         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8297         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8298         vv(1)=pizda(1,1)-pizda(2,2)
8299         vv(2)=pizda(1,2)+pizda(2,1)
8300         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8301 #ifdef MOMENT
8302         if (swap) then
8303           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8304         else
8305           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8306         endif
8307 #endif
8308         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8309 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8310       endif
8311 C Derivatives in gamma(l-1) or gamma(j-1)
8312       if (l.gt.1) then
8313 #ifdef MOMENT
8314         s1=dip(1,jj,i)*dipderg(3,kk,k)
8315 #endif
8316         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8317         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8318         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8319         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8320         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8321         vv(1)=pizda(1,1)-pizda(2,2)
8322         vv(2)=pizda(1,2)+pizda(2,1)
8323         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8324 #ifdef MOMENT
8325         if (swap) then
8326           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8327         else
8328           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8329         endif
8330 #endif
8331         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8332 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8333       endif
8334 C Cartesian derivatives.
8335       if (lprn) then
8336         write (2,*) 'In eello6_graph2'
8337         do iii=1,2
8338           write (2,*) 'iii=',iii
8339           do kkk=1,5
8340             write (2,*) 'kkk=',kkk
8341             do jjj=1,2
8342               write (2,'(3(2f10.5),5x)')
8343      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8344             enddo
8345           enddo
8346         enddo
8347       endif
8348       do iii=1,2
8349         do kkk=1,5
8350           do lll=1,3
8351 #ifdef MOMENT
8352             if (iii.eq.1) then
8353               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8354             else
8355               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8356             endif
8357 #endif
8358             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8359      &        auxvec(1))
8360             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8361             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8362      &        auxvec(1))
8363             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8364             call transpose2(EUg(1,1,k),auxmat(1,1))
8365             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8366      &        pizda(1,1))
8367             vv(1)=pizda(1,1)-pizda(2,2)
8368             vv(2)=pizda(1,2)+pizda(2,1)
8369             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8370 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8371 #ifdef MOMENT
8372             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8373 #else
8374             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8375 #endif
8376             if (swap) then
8377               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8378             else
8379               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8380             endif
8381           enddo
8382         enddo
8383       enddo
8384       return
8385       end
8386 c----------------------------------------------------------------------------
8387       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8388       implicit real*8 (a-h,o-z)
8389       include 'DIMENSIONS'
8390       include 'DIMENSIONS.ZSCOPT'
8391       include 'COMMON.IOUNITS'
8392       include 'COMMON.CHAIN'
8393       include 'COMMON.DERIV'
8394       include 'COMMON.INTERACT'
8395       include 'COMMON.CONTACTS'
8396       include 'COMMON.TORSION'
8397       include 'COMMON.VAR'
8398       include 'COMMON.GEO'
8399       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8400       logical swap
8401 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8402 C                                                                              C
8403 C      Parallel       Antiparallel                                             C
8404 C                                                                              C
8405 C          o             o                                                     C
8406 C         /l\   /   \   /j\                                                    C
8407 C        /   \ /     \ /   \                                                   C
8408 C       /| o |o       o| o |\                                                  C
8409 C       j|/k\|  /      |/k\|l /                                                C
8410 C        /   \ /       /   \ /                                                 C
8411 C       /     o       /     o                                                  C
8412 C       i             i                                                        C
8413 C                                                                              C
8414 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8415 C
8416 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8417 C           energy moment and not to the cluster cumulant.
8418       iti=itortyp(itype(i))
8419       if (j.lt.nres-1) then
8420         itj1=itortyp(itype(j+1))
8421       else
8422         itj1=ntortyp+1
8423       endif
8424       itk=itortyp(itype(k))
8425       itk1=itortyp(itype(k+1))
8426       if (l.lt.nres-1) then
8427         itl1=itortyp(itype(l+1))
8428       else
8429         itl1=ntortyp+1
8430       endif
8431 #ifdef MOMENT
8432       s1=dip(4,jj,i)*dip(4,kk,k)
8433 #endif
8434       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8435       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8436       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8437       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8438       call transpose2(EE(1,1,itk),auxmat(1,1))
8439       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8440       vv(1)=pizda(1,1)+pizda(2,2)
8441       vv(2)=pizda(2,1)-pizda(1,2)
8442       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8443 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8444 #ifdef MOMENT
8445       eello6_graph3=-(s1+s2+s3+s4)
8446 #else
8447       eello6_graph3=-(s2+s3+s4)
8448 #endif
8449 c      eello6_graph3=-s4
8450       if (.not. calc_grad) return
8451 C Derivatives in gamma(k-1)
8452       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8453       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8454       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8455       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8456 C Derivatives in gamma(l-1)
8457       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8458       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8459       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8460       vv(1)=pizda(1,1)+pizda(2,2)
8461       vv(2)=pizda(2,1)-pizda(1,2)
8462       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8463       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8464 C Cartesian derivatives.
8465       do iii=1,2
8466         do kkk=1,5
8467           do lll=1,3
8468 #ifdef MOMENT
8469             if (iii.eq.1) then
8470               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8471             else
8472               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8473             endif
8474 #endif
8475             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8476      &        auxvec(1))
8477             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8478             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8479      &        auxvec(1))
8480             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8481             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8482      &        pizda(1,1))
8483             vv(1)=pizda(1,1)+pizda(2,2)
8484             vv(2)=pizda(2,1)-pizda(1,2)
8485             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8486 #ifdef MOMENT
8487             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8488 #else
8489             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8490 #endif
8491             if (swap) then
8492               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8493             else
8494               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8495             endif
8496 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8497           enddo
8498         enddo
8499       enddo
8500       return
8501       end
8502 c----------------------------------------------------------------------------
8503       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8504       implicit real*8 (a-h,o-z)
8505       include 'DIMENSIONS'
8506       include 'DIMENSIONS.ZSCOPT'
8507       include 'COMMON.IOUNITS'
8508       include 'COMMON.CHAIN'
8509       include 'COMMON.DERIV'
8510       include 'COMMON.INTERACT'
8511       include 'COMMON.CONTACTS'
8512       include 'COMMON.TORSION'
8513       include 'COMMON.VAR'
8514       include 'COMMON.GEO'
8515       include 'COMMON.FFIELD'
8516       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8517      & auxvec1(2),auxmat1(2,2)
8518       logical swap
8519 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8520 C                                                                              C
8521 C      Parallel       Antiparallel                                             C
8522 C                                                                              C
8523 C          o             o                                                     C
8524 C         /l\   /   \   /j\                                                    C
8525 C        /   \ /     \ /   \                                                   C
8526 C       /| o |o       o| o |\                                                  C
8527 C     \ j|/k\|      \  |/k\|l                                                  C
8528 C      \ /   \       \ /   \                                                   C
8529 C       o     \       o     \                                                  C
8530 C       i             i                                                        C
8531 C                                                                              C
8532 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8533 C
8534 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8535 C           energy moment and not to the cluster cumulant.
8536 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8537       iti=itortyp(itype(i))
8538       itj=itortyp(itype(j))
8539       if (j.lt.nres-1) then
8540         itj1=itortyp(itype(j+1))
8541       else
8542         itj1=ntortyp+1
8543       endif
8544       itk=itortyp(itype(k))
8545       if (k.lt.nres-1) then
8546         itk1=itortyp(itype(k+1))
8547       else
8548         itk1=ntortyp+1
8549       endif
8550       itl=itortyp(itype(l))
8551       if (l.lt.nres-1) then
8552         itl1=itortyp(itype(l+1))
8553       else
8554         itl1=ntortyp+1
8555       endif
8556 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8557 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8558 cd     & ' itl',itl,' itl1',itl1
8559 #ifdef MOMENT
8560       if (imat.eq.1) then
8561         s1=dip(3,jj,i)*dip(3,kk,k)
8562       else
8563         s1=dip(2,jj,j)*dip(2,kk,l)
8564       endif
8565 #endif
8566       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8567       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8568       if (j.eq.l+1) then
8569         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8570         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8571       else
8572         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8573         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8574       endif
8575       call transpose2(EUg(1,1,k),auxmat(1,1))
8576       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8577       vv(1)=pizda(1,1)-pizda(2,2)
8578       vv(2)=pizda(2,1)+pizda(1,2)
8579       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8580 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8581 #ifdef MOMENT
8582       eello6_graph4=-(s1+s2+s3+s4)
8583 #else
8584       eello6_graph4=-(s2+s3+s4)
8585 #endif
8586       if (.not. calc_grad) return
8587 C Derivatives in gamma(i-1)
8588       if (i.gt.1) then
8589 #ifdef MOMENT
8590         if (imat.eq.1) then
8591           s1=dipderg(2,jj,i)*dip(3,kk,k)
8592         else
8593           s1=dipderg(4,jj,j)*dip(2,kk,l)
8594         endif
8595 #endif
8596         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8597         if (j.eq.l+1) then
8598           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8599           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8600         else
8601           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8602           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8603         endif
8604         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8605         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8606 cd          write (2,*) 'turn6 derivatives'
8607 #ifdef MOMENT
8608           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8609 #else
8610           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8611 #endif
8612         else
8613 #ifdef MOMENT
8614           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8615 #else
8616           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8617 #endif
8618         endif
8619       endif
8620 C Derivatives in gamma(k-1)
8621 #ifdef MOMENT
8622       if (imat.eq.1) then
8623         s1=dip(3,jj,i)*dipderg(2,kk,k)
8624       else
8625         s1=dip(2,jj,j)*dipderg(4,kk,l)
8626       endif
8627 #endif
8628       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8629       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8630       if (j.eq.l+1) then
8631         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8632         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8633       else
8634         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8635         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8636       endif
8637       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8638       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8639       vv(1)=pizda(1,1)-pizda(2,2)
8640       vv(2)=pizda(2,1)+pizda(1,2)
8641       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8642       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8643 #ifdef MOMENT
8644         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8645 #else
8646         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8647 #endif
8648       else
8649 #ifdef MOMENT
8650         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8651 #else
8652         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8653 #endif
8654       endif
8655 C Derivatives in gamma(j-1) or gamma(l-1)
8656       if (l.eq.j+1 .and. l.gt.1) then
8657         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8658         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8659         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8660         vv(1)=pizda(1,1)-pizda(2,2)
8661         vv(2)=pizda(2,1)+pizda(1,2)
8662         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8663         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8664       else if (j.gt.1) then
8665         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8666         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8667         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8668         vv(1)=pizda(1,1)-pizda(2,2)
8669         vv(2)=pizda(2,1)+pizda(1,2)
8670         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8671         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8672           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8673         else
8674           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8675         endif
8676       endif
8677 C Cartesian derivatives.
8678       do iii=1,2
8679         do kkk=1,5
8680           do lll=1,3
8681 #ifdef MOMENT
8682             if (iii.eq.1) then
8683               if (imat.eq.1) then
8684                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8685               else
8686                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8687               endif
8688             else
8689               if (imat.eq.1) then
8690                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8691               else
8692                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8693               endif
8694             endif
8695 #endif
8696             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8697      &        auxvec(1))
8698             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8699             if (j.eq.l+1) then
8700               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8701      &          b1(1,itj1),auxvec(1))
8702               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8703             else
8704               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8705      &          b1(1,itl1),auxvec(1))
8706               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8707             endif
8708             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8709      &        pizda(1,1))
8710             vv(1)=pizda(1,1)-pizda(2,2)
8711             vv(2)=pizda(2,1)+pizda(1,2)
8712             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8713             if (swap) then
8714               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8715 #ifdef MOMENT
8716                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8717      &             -(s1+s2+s4)
8718 #else
8719                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8720      &             -(s2+s4)
8721 #endif
8722                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8723               else
8724 #ifdef MOMENT
8725                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8726 #else
8727                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8728 #endif
8729                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8730               endif
8731             else
8732 #ifdef MOMENT
8733               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8734 #else
8735               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8736 #endif
8737               if (l.eq.j+1) then
8738                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8739               else
8740                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8741               endif
8742             endif
8743           enddo
8744         enddo
8745       enddo
8746       return
8747       end
8748 c----------------------------------------------------------------------------
8749       double precision function eello_turn6(i,jj,kk)
8750       implicit real*8 (a-h,o-z)
8751       include 'DIMENSIONS'
8752       include 'DIMENSIONS.ZSCOPT'
8753       include 'COMMON.IOUNITS'
8754       include 'COMMON.CHAIN'
8755       include 'COMMON.DERIV'
8756       include 'COMMON.INTERACT'
8757       include 'COMMON.CONTACTS'
8758       include 'COMMON.TORSION'
8759       include 'COMMON.VAR'
8760       include 'COMMON.GEO'
8761       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8762      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8763      &  ggg1(3),ggg2(3)
8764       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8765      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8766 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8767 C           the respective energy moment and not to the cluster cumulant.
8768       eello_turn6=0.0d0
8769       j=i+4
8770       k=i+1
8771       l=i+3
8772       iti=itortyp(itype(i))
8773       itk=itortyp(itype(k))
8774       itk1=itortyp(itype(k+1))
8775       itl=itortyp(itype(l))
8776       itj=itortyp(itype(j))
8777 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8778 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8779 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8780 cd        eello6=0.0d0
8781 cd        return
8782 cd      endif
8783 cd      write (iout,*)
8784 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8785 cd     &   ' and',k,l
8786 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8787       do iii=1,2
8788         do kkk=1,5
8789           do lll=1,3
8790             derx_turn(lll,kkk,iii)=0.0d0
8791           enddo
8792         enddo
8793       enddo
8794 cd      eij=1.0d0
8795 cd      ekl=1.0d0
8796 cd      ekont=1.0d0
8797       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8798 cd      eello6_5=0.0d0
8799 cd      write (2,*) 'eello6_5',eello6_5
8800 #ifdef MOMENT
8801       call transpose2(AEA(1,1,1),auxmat(1,1))
8802       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8803       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8804       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8805 #else
8806       s1 = 0.0d0
8807 #endif
8808       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8809       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8810       s2 = scalar2(b1(1,itk),vtemp1(1))
8811 #ifdef MOMENT
8812       call transpose2(AEA(1,1,2),atemp(1,1))
8813       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8814       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8815       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8816 #else
8817       s8=0.0d0
8818 #endif
8819       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8820       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8821       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8822 #ifdef MOMENT
8823       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8824       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8825       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8826       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8827       ss13 = scalar2(b1(1,itk),vtemp4(1))
8828       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8829 #else
8830       s13=0.0d0
8831 #endif
8832 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8833 c      s1=0.0d0
8834 c      s2=0.0d0
8835 c      s8=0.0d0
8836 c      s12=0.0d0
8837 c      s13=0.0d0
8838       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8839       if (calc_grad) then
8840 C Derivatives in gamma(i+2)
8841 #ifdef MOMENT
8842       call transpose2(AEA(1,1,1),auxmatd(1,1))
8843       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8844       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8845       call transpose2(AEAderg(1,1,2),atempd(1,1))
8846       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8847       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8848 #else
8849       s8d=0.0d0
8850 #endif
8851       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8852       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8853       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8854 c      s1d=0.0d0
8855 c      s2d=0.0d0
8856 c      s8d=0.0d0
8857 c      s12d=0.0d0
8858 c      s13d=0.0d0
8859       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8860 C Derivatives in gamma(i+3)
8861 #ifdef MOMENT
8862       call transpose2(AEA(1,1,1),auxmatd(1,1))
8863       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8864       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8865       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8866 #else
8867       s1d=0.0d0
8868 #endif
8869       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8870       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8871       s2d = scalar2(b1(1,itk),vtemp1d(1))
8872 #ifdef MOMENT
8873       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8874       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8875 #endif
8876       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8877 #ifdef MOMENT
8878       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8879       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8880       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8881 #else
8882       s13d=0.0d0
8883 #endif
8884 c      s1d=0.0d0
8885 c      s2d=0.0d0
8886 c      s8d=0.0d0
8887 c      s12d=0.0d0
8888 c      s13d=0.0d0
8889 #ifdef MOMENT
8890       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8891      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8892 #else
8893       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8894      &               -0.5d0*ekont*(s2d+s12d)
8895 #endif
8896 C Derivatives in gamma(i+4)
8897       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8898       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8899       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8900 #ifdef MOMENT
8901       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8902       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8903       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8904 #else
8905       s13d = 0.0d0
8906 #endif
8907 c      s1d=0.0d0
8908 c      s2d=0.0d0
8909 c      s8d=0.0d0
8910 C      s12d=0.0d0
8911 c      s13d=0.0d0
8912 #ifdef MOMENT
8913       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8914 #else
8915       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8916 #endif
8917 C Derivatives in gamma(i+5)
8918 #ifdef MOMENT
8919       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8920       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8921       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8922 #else
8923       s1d = 0.0d0
8924 #endif
8925       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8926       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8927       s2d = scalar2(b1(1,itk),vtemp1d(1))
8928 #ifdef MOMENT
8929       call transpose2(AEA(1,1,2),atempd(1,1))
8930       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8931       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8932 #else
8933       s8d = 0.0d0
8934 #endif
8935       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8936       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8937 #ifdef MOMENT
8938       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8939       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8940       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8941 #else
8942       s13d = 0.0d0
8943 #endif
8944 c      s1d=0.0d0
8945 c      s2d=0.0d0
8946 c      s8d=0.0d0
8947 c      s12d=0.0d0
8948 c      s13d=0.0d0
8949 #ifdef MOMENT
8950       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8951      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8952 #else
8953       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8954      &               -0.5d0*ekont*(s2d+s12d)
8955 #endif
8956 C Cartesian derivatives
8957       do iii=1,2
8958         do kkk=1,5
8959           do lll=1,3
8960 #ifdef MOMENT
8961             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8962             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8963             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8964 #else
8965             s1d = 0.0d0
8966 #endif
8967             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8968             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8969      &          vtemp1d(1))
8970             s2d = scalar2(b1(1,itk),vtemp1d(1))
8971 #ifdef MOMENT
8972             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8973             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8974             s8d = -(atempd(1,1)+atempd(2,2))*
8975      &           scalar2(cc(1,1,itl),vtemp2(1))
8976 #else
8977             s8d = 0.0d0
8978 #endif
8979             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8980      &           auxmatd(1,1))
8981             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8982             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8983 c      s1d=0.0d0
8984 c      s2d=0.0d0
8985 c      s8d=0.0d0
8986 c      s12d=0.0d0
8987 c      s13d=0.0d0
8988 #ifdef MOMENT
8989             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8990      &        - 0.5d0*(s1d+s2d)
8991 #else
8992             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8993      &        - 0.5d0*s2d
8994 #endif
8995 #ifdef MOMENT
8996             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8997      &        - 0.5d0*(s8d+s12d)
8998 #else
8999             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9000      &        - 0.5d0*s12d
9001 #endif
9002           enddo
9003         enddo
9004       enddo
9005 #ifdef MOMENT
9006       do kkk=1,5
9007         do lll=1,3
9008           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9009      &      achuj_tempd(1,1))
9010           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9011           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9012           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9013           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9014           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9015      &      vtemp4d(1))
9016           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9017           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9018           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9019         enddo
9020       enddo
9021 #endif
9022 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9023 cd     &  16*eel_turn6_num
9024 cd      goto 1112
9025       if (j.lt.nres-1) then
9026         j1=j+1
9027         j2=j-1
9028       else
9029         j1=j-1
9030         j2=j-2
9031       endif
9032       if (l.lt.nres-1) then
9033         l1=l+1
9034         l2=l-1
9035       else
9036         l1=l-1
9037         l2=l-2
9038       endif
9039       do ll=1,3
9040         ggg1(ll)=eel_turn6*g_contij(ll,1)
9041         ggg2(ll)=eel_turn6*g_contij(ll,2)
9042         ghalf=0.5d0*ggg1(ll)
9043 cd        ghalf=0.0d0
9044         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
9045      &    +ekont*derx_turn(ll,2,1)
9046         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9047         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
9048      &    +ekont*derx_turn(ll,4,1)
9049         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9050         ghalf=0.5d0*ggg2(ll)
9051 cd        ghalf=0.0d0
9052         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
9053      &    +ekont*derx_turn(ll,2,2)
9054         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9055         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
9056      &    +ekont*derx_turn(ll,4,2)
9057         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9058       enddo
9059 cd      goto 1112
9060       do m=i+1,j-1
9061         do ll=1,3
9062           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9063         enddo
9064       enddo
9065       do m=k+1,l-1
9066         do ll=1,3
9067           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9068         enddo
9069       enddo
9070 1112  continue
9071       do m=i+2,j2
9072         do ll=1,3
9073           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9074         enddo
9075       enddo
9076       do m=k+2,l2
9077         do ll=1,3
9078           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9079         enddo
9080       enddo
9081 cd      do iii=1,nres-3
9082 cd        write (2,*) iii,g_corr6_loc(iii)
9083 cd      enddo
9084       endif
9085       eello_turn6=ekont*eel_turn6
9086 cd      write (2,*) 'ekont',ekont
9087 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9088       return
9089       end
9090 crc-------------------------------------------------
9091       SUBROUTINE MATVEC2(A1,V1,V2)
9092       implicit real*8 (a-h,o-z)
9093       include 'DIMENSIONS'
9094       DIMENSION A1(2,2),V1(2),V2(2)
9095 c      DO 1 I=1,2
9096 c        VI=0.0
9097 c        DO 3 K=1,2
9098 c    3     VI=VI+A1(I,K)*V1(K)
9099 c        Vaux(I)=VI
9100 c    1 CONTINUE
9101
9102       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9103       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9104
9105       v2(1)=vaux1
9106       v2(2)=vaux2
9107       END
9108 C---------------------------------------
9109       SUBROUTINE MATMAT2(A1,A2,A3)
9110       implicit real*8 (a-h,o-z)
9111       include 'DIMENSIONS'
9112       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9113 c      DIMENSION AI3(2,2)
9114 c        DO  J=1,2
9115 c          A3IJ=0.0
9116 c          DO K=1,2
9117 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9118 c          enddo
9119 c          A3(I,J)=A3IJ
9120 c       enddo
9121 c      enddo
9122
9123       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9124       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9125       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9126       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9127
9128       A3(1,1)=AI3_11
9129       A3(2,1)=AI3_21
9130       A3(1,2)=AI3_12
9131       A3(2,2)=AI3_22
9132       END
9133
9134 c-------------------------------------------------------------------------
9135       double precision function scalar2(u,v)
9136       implicit none
9137       double precision u(2),v(2)
9138       double precision sc
9139       integer i
9140       scalar2=u(1)*v(1)+u(2)*v(2)
9141       return
9142       end
9143
9144 C-----------------------------------------------------------------------------
9145
9146       subroutine transpose2(a,at)
9147       implicit none
9148       double precision a(2,2),at(2,2)
9149       at(1,1)=a(1,1)
9150       at(1,2)=a(2,1)
9151       at(2,1)=a(1,2)
9152       at(2,2)=a(2,2)
9153       return
9154       end
9155 c--------------------------------------------------------------------------
9156       subroutine transpose(n,a,at)
9157       implicit none
9158       integer n,i,j
9159       double precision a(n,n),at(n,n)
9160       do i=1,n
9161         do j=1,n
9162           at(j,i)=a(i,j)
9163         enddo
9164       enddo
9165       return
9166       end
9167 C---------------------------------------------------------------------------
9168       subroutine prodmat3(a1,a2,kk,transp,prod)
9169       implicit none
9170       integer i,j
9171       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9172       logical transp
9173 crc      double precision auxmat(2,2),prod_(2,2)
9174
9175       if (transp) then
9176 crc        call transpose2(kk(1,1),auxmat(1,1))
9177 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9178 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9179
9180            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9181      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9182            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9183      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9184            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9185      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9186            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9187      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9188
9189       else
9190 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9191 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9192
9193            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9194      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9195            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9196      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9197            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9198      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9199            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9200      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9201
9202       endif
9203 c      call transpose2(a2(1,1),a2t(1,1))
9204
9205 crc      print *,transp
9206 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9207 crc      print *,((prod(i,j),i=1,2),j=1,2)
9208
9209       return
9210       end
9211 C-----------------------------------------------------------------------------
9212       double precision function scalar(u,v)
9213       implicit none
9214       double precision u(3),v(3)
9215       double precision sc
9216       integer i
9217       sc=0.0d0
9218       do i=1,3
9219         sc=sc+u(i)*v(i)
9220       enddo
9221       scalar=sc
9222       return
9223       end
9224