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        IF (energy_dec) write (iout,'(a)')
1075      & ' AAi i  AAj  j  1/rij  Rtail   Rhead   evdwij   Fcav   Ecl
1076      & Egb   Epol   Fisocav   Elj   Equad   evdw'
1077        evdw   = 0.0D0
1078        evdw_p = 0.0D0
1079        evdw_m = 0.0D0
1080 c DIAGNOSTICS
1081 ccccc      energy_dec=.false.
1082 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1083 c      lprn   = .false.
1084 c     if (icall.eq.0) lprn=.false.
1085 c END DIAGNOSTICS
1086 c      ind = 0
1087        DO i = iatsc_s, iatsc_e
1088         itypi  = itype(i)
1089 c        itypi1 = itype(i+1)
1090         dxi    = dc_norm(1,nres+i)
1091         dyi    = dc_norm(2,nres+i)
1092         dzi    = dc_norm(3,nres+i)
1093 c        dsci_inv=dsc_inv(itypi)
1094         dsci_inv = vbld_inv(i+nres)
1095 c        DO k = 1, 3
1096 c         ctail(k,1) = c(k, i+nres)
1097 c     &              - dtail(1,itypi,itypj) * dc_norm(k, nres+i)
1098 c        END DO
1099         xi=c(1,nres+i)
1100         yi=c(2,nres+i)
1101         zi=c(3,nres+i)
1102 c!-------------------------------------------------------------------
1103 C Calculate SC interaction energy.
1104         DO iint = 1, nint_gr(i)
1105          DO j = istart(i,iint), iend(i,iint)
1106 c! initialize variables for electrostatic gradients
1107           CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
1108 c            ind=ind+1
1109 c            dscj_inv = dsc_inv(itypj)
1110           dscj_inv = vbld_inv(j+nres)
1111 c! rij holds 1/(distance of Calpha atoms)
1112           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
1113           rij  = dsqrt(rrij)
1114 c!-------------------------------------------------------------------
1115 C Calculate angle-dependent terms of energy and contributions to their
1116 C derivatives.
1117
1118 #IFDEF CHECK_MOMO
1119 c!      DO troll = 10, 5000
1120 c!      om1    = 0.0d0
1121 c!      om2    = 0.0d0
1122 c!      om12   = 1.0d0
1123 c!      sqom1  = om1 * om1
1124 c!      sqom2  = om2 * om2
1125 c!      sqom12 = om12 * om12
1126 c!      rij    = 5.0d0 / troll
1127 c!      rrij   = rij * rij
1128 c!      Rtail  = troll / 5.0d0
1129 c!      Rhead  = troll / 5.0d0
1130 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1131 c!      Rtail = dsqrt((Rtail**2)
1132 c!     &      +((dabs(dtail(1,itypi,itypj)-dtail(2,itypi,itypj)))**2))
1133 c!      rij = 1.0d0/Rtail
1134 c!      rrij = rij * rij
1135 #ENDIF
1136           CALL sc_angular
1137 c! this should be in elgrad_init but om's are calculated by sc_angular
1138 c! which in turn is used by older potentials
1139 c! which proves how tangled UNRES code is >.<
1140 c! om = omega, sqom = om^2
1141           sqom1  = om1 * om1
1142           sqom2  = om2 * om2
1143           sqom12 = om12 * om12
1144
1145 c! now we calculate EGB - Gey-Berne
1146 c! It will be summed up in evdwij and saved in evdw
1147           sigsq     = 1.0D0  / sigsq
1148           sig       = sig0ij * dsqrt(sigsq)
1149 c!          rij_shift = 1.0D0  / rij - sig + sig0ij
1150           rij_shift = Rtail - sig + sig0ij
1151 c          write (2,*) "Rtal",Rtail," sig",sig," sigsq",sigsq,
1152 c     &       " sig0ij",sig0ij
1153 c          write (2,*) "rij_shift",rij_shift
1154           IF (rij_shift.le.0.0D0) THEN
1155            evdw = 1.0D20
1156            RETURN
1157           END IF
1158           sigder = -sig * sigsq
1159           rij_shift = 1.0D0 / rij_shift
1160           fac       = rij_shift**expon
1161           c1        = fac  * fac * aa(itypi,itypj)
1162 #ifdef SCALREP
1163 ! Scale down the repulsive term for 1,4 interactions.
1164           if (iabs(j-i).le.4) c1  = 0.01d0 * c1
1165 #endif
1166 c!          c1        = 0.0d0
1167           c2        = fac  * bb(itypi,itypj)
1168 c!          c2        = 0.0d0
1169 c          write (2,*) "eps1",eps1," eps2rt",eps2rt," eps3rt",eps3rt,
1170 c     &     " c1",c1," c2",c2
1171           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
1172           eps2der   = eps3rt * evdwij
1173           eps3der   = eps2rt * evdwij
1174 c!          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
1175           evdwij    = eps2rt * eps3rt * evdwij
1176 c!      evdwij = 0.0d0
1177 c!      write (*,*) "Gey Berne = ", evdwij
1178 #ifdef TSCSC
1179           IF (bb(itypi,itypj).gt.0) THEN
1180            evdw_p = evdw_p + evdwij
1181           ELSE
1182            evdw_m = evdw_m + evdwij
1183           END IF
1184 #else
1185           evdw = evdw
1186      &         + evdwij
1187 #endif
1188 c!-------------------------------------------------------------------
1189 c! Calculate some components of GGB
1190           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
1191           fac    = -expon * (c1 + evdwij) * rij_shift
1192           sigder = fac * sigder
1193 c!          fac    = rij * fac
1194 c! Calculate distance derivative
1195 c!          gg(1) = xj * fac
1196 c!          gg(2) = yj * fac
1197 c!          gg(3) = zj * fac
1198           gg(1) = fac
1199           gg(2) = fac
1200           gg(3) = fac
1201 c!      write (*,*) "gg(1) = ", gg(1)
1202 c!      write (*,*) "gg(2) = ", gg(2)
1203 c!      write (*,*) "gg(3) = ", gg(3)
1204 c! The angular derivatives of GGB are brought together in sc_grad
1205 c!-------------------------------------------------------------------
1206 c! Fcav
1207 c!
1208 c! Catch gly-gly interactions to skip calculation of something that
1209 c! does not exist
1210
1211       IF (itypi.eq.10.and.itypj.eq.10) THEN
1212        Fcav = 0.0d0
1213        dFdR = 0.0d0
1214        dCAVdOM1  = 0.0d0
1215        dCAVdOM2  = 0.0d0
1216        dCAVdOM12 = 0.0d0
1217       ELSE
1218
1219 c! we are not 2 glycines, so we calculate Fcav (and maybe more)
1220        fac = chis1 * sqom1 + chis2 * sqom2
1221      &     - 2.0d0 * chis12 * om1 * om2 * om12
1222 c! we will use pom later in Gcav, so dont mess with it!
1223        pom = 1.0d0 - chis1 * chis2 * sqom12
1224
1225        Lambf = (1.0d0 - (fac / pom))
1226        Lambf = dsqrt(Lambf)
1227
1228
1229        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
1230 c!       write (*,*) "sparrow = ", sparrow
1231        Chif = Rtail * sparrow
1232        ChiLambf = Chif * Lambf
1233        eagle = dsqrt(ChiLambf)
1234        bat = ChiLambf ** 11.0d0
1235
1236        top = b1 * ( eagle + b2 * ChiLambf - b3 )
1237        bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
1238        botsq = bot * bot
1239
1240 c!      write (*,*) "sig1 = ",sig1
1241 c!      write (*,*) "sig2 = ",sig2
1242 c!      write (*,*) "Rtail = ",Rtail
1243 c!      write (*,*) "sparrow = ",sparrow
1244 c!      write (*,*) "Chis1 = ", chis1
1245 c!      write (*,*) "Chis2 = ", chis2
1246 c!      write (*,*) "Chis12 = ", chis12
1247 c!      write (*,*) "om1 = ", om1
1248 c!      write (*,*) "om2 = ", om2
1249 c!      write (*,*) "om12 = ", om12
1250 c!      write (*,*) "sqom1 = ", sqom1
1251 c!      write (*,*) "sqom2 = ", sqom2
1252 c!      write (*,*) "sqom12 = ", sqom12
1253 c!      write (*,*) "Lambf = ",Lambf
1254 c!      write (*,*) "b1 = ",b1
1255 c!      write (*,*) "b2 = ",b2
1256 c!      write (*,*) "b3 = ",b3
1257 c!      write (*,*) "b4 = ",b4
1258 c!      write (*,*) "top = ",top
1259 c!      write (*,*) "bot = ",bot
1260        Fcav = top / bot
1261 c!       Fcav = 0.0d0
1262 c!      write (*,*) "Fcav = ", Fcav
1263 c!-------------------------------------------------------------------
1264 c! derivative of Fcav is Gcav...
1265 c!---------------------------------------------------
1266
1267        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
1268        dbot = 12.0d0 * b4 * bat * Lambf
1269        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
1270 c!       dFdR = 0.0d0
1271 c!      write (*,*) "dFcav/dR = ", dFdR
1272
1273        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
1274        dbot = 12.0d0 * b4 * bat * Chif
1275        eagle = Lambf * pom
1276        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
1277        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
1278        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)
1279      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)
1280
1281        dFdL = ((dtop * bot - top * dbot) / botsq)
1282 c!       dFdL = 0.0d0
1283        dCAVdOM1  = dFdL * ( dFdOM1 )
1284        dCAVdOM2  = dFdL * ( dFdOM2 )
1285        dCAVdOM12 = dFdL * ( dFdOM12 )
1286 c!      write (*,*) "dFcav/dOM1 = ", dCAVdOM1
1287 c!      write (*,*) "dFcav/dOM2 = ", dCAVdOM2
1288 c!      write (*,*) "dFcav/dOM12 = ", dCAVdOM12
1289 c!      write (*,*) ""
1290 c!-------------------------------------------------------------------
1291 c! Finally, add the distance derivatives of GB and Fcav to gvdwc
1292 c! Pom is used here to project the gradient vector into
1293 c! cartesian coordinates and at the same time contains
1294 c! dXhb/dXsc derivative (for charged amino acids
1295 c! location of hydrophobic centre of interaction is not
1296 c! the same as geometric centre of side chain, this
1297 c! derivative takes that into account)
1298 c! derivatives of omega angles will be added in sc_grad
1299
1300        DO k= 1, 3
1301         ertail(k) = Rtail_distance(k)/Rtail
1302        END DO
1303        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
1304        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
1305        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1306        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1307        DO k = 1, 3
1308 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1309 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1310         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
1311         gvdwx(k,i) = gvdwx(k,i)
1312      &             - (( dFdR + gg(k) ) * pom)
1313 c!     &             - ( dFdR * pom )
1314         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
1315         gvdwx(k,j) = gvdwx(k,j)
1316      &             + (( dFdR + gg(k) ) * pom)
1317 c!     &             + ( dFdR * pom )
1318
1319         gvdwc(k,i) = gvdwc(k,i)
1320      &             - (( dFdR + gg(k) ) * ertail(k))
1321 c!     &             - ( dFdR * ertail(k))
1322
1323         gvdwc(k,j) = gvdwc(k,j)
1324      &             + (( dFdR + gg(k) ) * ertail(k))
1325 c!     &             + ( dFdR * ertail(k))
1326
1327         gg(k) = 0.0d0
1328 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1329 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1330       END DO
1331
1332 c!-------------------------------------------------------------------
1333 c! Compute head-head and head-tail energies for each state
1334
1335           isel = iabs(Qi) + iabs(Qj)
1336           IF (isel.eq.0) THEN
1337 c! No charges - do nothing
1338            eheadtail = 0.0d0
1339
1340           ELSE IF (isel.eq.4) THEN
1341 c! Calculate dipole-dipole interactions
1342            CALL edd(ecl)
1343            eheadtail = ECL
1344
1345           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
1346 c! Charge-nonpolar interactions
1347            CALL eqn(epol)
1348            eheadtail = epol
1349
1350           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
1351 c! Nonpolar-charge interactions
1352            CALL enq(epol)
1353            eheadtail = epol
1354
1355           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
1356 c! Charge-dipole interactions
1357            CALL eqd(ecl, elj, epol)
1358            eheadtail = ECL + elj + epol
1359
1360           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
1361 c! Dipole-charge interactions
1362            CALL edq(ecl, elj, epol)
1363            eheadtail = ECL + elj + epol
1364
1365           ELSE IF ((isel.eq.2.and.
1366      &          iabs(Qi).eq.1).and.
1367      &          nstate(itypi,itypj).eq.1) THEN
1368 c! Same charge-charge interaction ( +/+ or -/- )
1369            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
1370            eheadtail = ECL + Egb + Epol + Fisocav + Elj
1371
1372           ELSE IF ((isel.eq.2.and.
1373      &          iabs(Qi).eq.1).and.
1374      &          nstate(itypi,itypj).ne.1) THEN
1375 c! Different charge-charge interaction ( +/- or -/+ )
1376            CALL energy_quad
1377      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1378           END IF
1379        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
1380 c!      write (*,*) "evdw = ", evdw
1381 c!      write (*,*) "Fcav = ", Fcav
1382 c!      write (*,*) "eheadtail = ", eheadtail
1383        evdw = evdw
1384      &      + Fcav
1385      &      + eheadtail
1386
1387        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)')
1388      &  restyp(itype(i)),i,restyp(itype(j)),j,
1389      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1390      &  Equad,evdwij+Fcav+eheadtail,evdw
1391 c       IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
1392 c     &  restyp(itype(i)),i,restyp(itype(j)),j,
1393 c     &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1394 c     &  Equad,evdwij+Fcav+eheadtail,evdw
1395 #IFDEF CHECK_MOMO
1396        evdw = 0.0d0
1397        END DO ! troll
1398 #ENDIF
1399
1400 c!-------------------------------------------------------------------
1401 c! As all angular derivatives are done, now we sum them up,
1402 c! then transform and project into cartesian vectors and add to gvdwc
1403 c! We call sc_grad always, with the exception of +/- interaction.
1404 c! This is because energy_quad subroutine needs to handle
1405 c! this job in his own way.
1406 c! This IS probably not very efficient and SHOULD be optimised
1407 c! but it will require major restructurization of emomo
1408 c! so it will be left as it is for now
1409 c!       write (*,*) 'troll1, nstate =', nstate (itypi,itypj)
1410        IF (nstate(itypi,itypj).eq.1) THEN
1411 #ifdef TSCSC
1412         IF (bb(itypi,itypj).gt.0) THEN
1413          CALL sc_grad
1414         ELSE
1415          CALL sc_grad_T
1416         END IF
1417 #else
1418         CALL sc_grad
1419 #endif
1420        END IF
1421 c!-------------------------------------------------------------------
1422 c! NAPISY KONCOWE
1423          END DO   ! j
1424         END DO    ! iint
1425        END DO     ! i
1426        if (energy_dec) write (iout,*) "evdw before exiting emomo:",evdw
1427 c      write (iout,*) "Number of loop steps in EGB:",ind
1428 c      energy_dec=.false.
1429        RETURN
1430       END SUBROUTINE emomo
1431 c! END OF MOMO
1432
1433
1434 C-----------------------------------------------------------------------------
1435
1436
1437       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
1438        IMPLICIT NONE
1439        INCLUDE 'DIMENSIONS'
1440        INCLUDE 'DIMENSIONS.ZSCOPT'
1441        INCLUDE 'COMMON.CALC'
1442        INCLUDE 'COMMON.CHAIN'
1443        INCLUDE 'COMMON.CONTROL'
1444        INCLUDE 'COMMON.DERIV'
1445        INCLUDE 'COMMON.EMP'
1446        INCLUDE 'COMMON.GEO'
1447        INCLUDE 'COMMON.INTERACT'
1448        INCLUDE 'COMMON.IOUNITS'
1449        INCLUDE 'COMMON.LOCAL'
1450        INCLUDE 'COMMON.NAMES'
1451        INCLUDE 'COMMON.VAR'
1452        double precision scalar, facd3, facd4, federmaus, adler
1453 c! Epol and Gpol analytical parameters
1454        alphapol1 = alphapol(itypi,itypj)
1455        alphapol2 = alphapol(itypj,itypi)
1456 c! Fisocav and Gisocav analytical parameters
1457        al1  = alphiso(1,itypi,itypj)
1458        al2  = alphiso(2,itypi,itypj)
1459        al3  = alphiso(3,itypi,itypj)
1460        al4  = alphiso(4,itypi,itypj)
1461        csig = (1.0d0
1462      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1463      &      + sigiso2(itypi,itypj)**2.0d0))
1464 c!
1465        pis  = sig0head(itypi,itypj)
1466        eps_head = epshead(itypi,itypj)
1467        Rhead_sq = Rhead * Rhead
1468 c! R1 - distance between head of ith side chain and tail of jth sidechain
1469 c! R2 - distance between head of jth side chain and tail of ith sidechain
1470        R1 = 0.0d0
1471        R2 = 0.0d0
1472        DO k = 1, 3
1473 c! Calculate head-to-tail distances needed by Epol
1474         R1=R1+(ctail(k,2)-chead(k,1))**2
1475         R2=R2+(chead(k,2)-ctail(k,1))**2
1476        END DO
1477 c! Pitagoras
1478        R1 = dsqrt(R1)
1479        R2 = dsqrt(R2)
1480
1481 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1482 c!     &        +dhead(1,1,itypi,itypj))**2))
1483 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1484 c!     &        +dhead(2,1,itypi,itypj))**2))
1485
1486 c!-------------------------------------------------------------------
1487 c! Coulomb electrostatic interaction
1488        Ecl = (332.0d0 * Qij) / Rhead
1489 c! derivative of Ecl is Gcl...
1490        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
1491        dGCLdOM1 = 0.0d0
1492        dGCLdOM2 = 0.0d0
1493        dGCLdOM12 = 0.0d0
1494 c!-------------------------------------------------------------------
1495 c! Generalised Born Solvent Polarization
1496 c! Charged head polarizes the solvent
1497        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1498        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1499        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1500 c! Derivative of Egb is Ggb...
1501        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1502        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1503      &        / ( 2.0d0 * Fgb )
1504        dGGBdR = dGGBdFGB * dFGBdR
1505 c!-------------------------------------------------------------------
1506 c! Fisocav - isotropic cavity creation term
1507 c! or "how much energy it costs to put charged head in water"
1508        pom = Rhead * csig
1509        top = al1 * (dsqrt(pom) + al2 * pom - al3)
1510        bot = (1.0d0 + al4 * pom**12.0d0)
1511        botsq = bot * bot
1512        FisoCav = top / bot
1513 c!      write (*,*) "Rhead = ",Rhead
1514 c!      write (*,*) "csig = ",csig
1515 c!      write (*,*) "pom = ",pom
1516 c!      write (*,*) "al1 = ",al1
1517 c!      write (*,*) "al2 = ",al2
1518 c!      write (*,*) "al3 = ",al3
1519 c!      write (*,*) "al4 = ",al4
1520 c!      write (*,*) "top = ",top
1521 c!      write (*,*) "bot = ",bot
1522 c! Derivative of Fisocav is GCV...
1523        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1524        dbot = 12.0d0 * al4 * pom ** 11.0d0
1525        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1526 c!-------------------------------------------------------------------
1527 c! Epol
1528 c! Polarization energy - charged heads polarize hydrophobic "neck"
1529        MomoFac1 = (1.0d0 - chi1 * sqom2)
1530        MomoFac2 = (1.0d0 - chi2 * sqom1)
1531        RR1  = ( R1 * R1 ) / MomoFac1
1532        RR2  = ( R2 * R2 ) / MomoFac2
1533        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1534        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1535        fgb1 = sqrt( RR1 + a12sq * ee1 )
1536        fgb2 = sqrt( RR2 + a12sq * ee2 )
1537        epol = 332.0d0 * eps_inout_fac * (
1538      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1539 c!       epol = 0.0d0
1540 c       write (*,*) "eps_inout_fac = ",eps_inout_fac
1541 c       write (*,*) "alphapol1 = ", alphapol1
1542 c       write (*,*) "alphapol2 = ", alphapol2
1543 c       write (*,*) "fgb1 = ", fgb1
1544 c       write (*,*) "fgb2 = ", fgb2
1545 c       write (*,*) "epol = ", epol
1546 c! derivative of Epol is Gpol...
1547        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1548      &          / (fgb1 ** 5.0d0)
1549        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1550      &          / (fgb2 ** 5.0d0)
1551        dFGBdR1 = ( (R1 / MomoFac1)
1552      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
1553      &        / ( 2.0d0 * fgb1 )
1554        dFGBdR2 = ( (R2 / MomoFac2)
1555      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
1556      &        / ( 2.0d0 * fgb2 )
1557        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1558      &          * ( 2.0d0 - 0.5d0 * ee1) )
1559      &          / ( 2.0d0 * fgb1 )
1560        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1561      &          * ( 2.0d0 - 0.5d0 * ee2) )
1562      &          / ( 2.0d0 * fgb2 )
1563        dPOLdR1 = dPOLdFGB1 * dFGBdR1
1564 c!       dPOLdR1 = 0.0d0
1565        dPOLdR2 = dPOLdFGB2 * dFGBdR2
1566 c!       dPOLdR2 = 0.0d0
1567        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1568 c!       dPOLdOM1 = 0.0d0
1569        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1570 c!       dPOLdOM2 = 0.0d0
1571 c!-------------------------------------------------------------------
1572 c! Elj
1573 c! Lennard-Jones 6-12 interaction between heads
1574        pom = (pis / Rhead)**6.0d0
1575        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1576 c! derivative of Elj is Glj
1577        dGLJdR = 4.0d0 * eps_head
1578      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1579      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1580 c!-------------------------------------------------------------------
1581 c! Return the results
1582 c! These things do the dRdX derivatives, that is
1583 c! allow us to change what we see from function that changes with
1584 c! distance to function that changes with LOCATION (of the interaction
1585 c! site)
1586        DO k = 1, 3
1587         erhead(k) = Rhead_distance(k)/Rhead
1588         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1589         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1590        END DO
1591
1592        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1593        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1594        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1595        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1596        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1597        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1598        facd1 = d1 * vbld_inv(i+nres)
1599        facd2 = d2 * vbld_inv(j+nres)
1600        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1601        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1602
1603 c! Now we add appropriate partial derivatives (one in each dimension)
1604        DO k = 1, 3
1605         hawk   = (erhead_tail(k,1) +
1606      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
1607         condor = (erhead_tail(k,2) +
1608      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
1609
1610         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1611         gvdwx(k,i) = gvdwx(k,i)
1612      &             - dGCLdR * pom
1613      &             - dGGBdR * pom
1614      &             - dGCVdR * pom
1615      &             - dPOLdR1 * hawk
1616      &             - dPOLdR2 * (erhead_tail(k,2)
1617      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1618      &             - dGLJdR * pom
1619
1620         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1621         gvdwx(k,j) = gvdwx(k,j)
1622      &             + dGCLdR * pom
1623      &             + dGGBdR * pom
1624      &             + dGCVdR * pom
1625      &             + dPOLdR1 * (erhead_tail(k,1)
1626      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1627      &             + dPOLdR2 * condor
1628      &             + dGLJdR * pom
1629
1630         gvdwc(k,i) = gvdwc(k,i)
1631      &             - dGCLdR * erhead(k)
1632      &             - dGGBdR * erhead(k)
1633      &             - dGCVdR * erhead(k)
1634      &             - dPOLdR1 * erhead_tail(k,1)
1635      &             - dPOLdR2 * erhead_tail(k,2)
1636      &             - dGLJdR * erhead(k)
1637
1638         gvdwc(k,j) = gvdwc(k,j)
1639      &             + dGCLdR * erhead(k)
1640      &             + dGGBdR * erhead(k)
1641      &             + dGCVdR * erhead(k)
1642      &             + dPOLdR1 * erhead_tail(k,1)
1643      &             + dPOLdR2 * erhead_tail(k,2)
1644      &             + dGLJdR * erhead(k)
1645
1646        END DO
1647        RETURN
1648       END SUBROUTINE eqq
1649 c!-------------------------------------------------------------------
1650       SUBROUTINE energy_quad
1651      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1652        IMPLICIT NONE
1653        INCLUDE 'DIMENSIONS'
1654        INCLUDE 'DIMENSIONS.ZSCOPT'
1655        INCLUDE 'COMMON.CALC'
1656        INCLUDE 'COMMON.CHAIN'
1657        INCLUDE 'COMMON.CONTROL'
1658        INCLUDE 'COMMON.DERIV'
1659        INCLUDE 'COMMON.EMP'
1660        INCLUDE 'COMMON.GEO'
1661        INCLUDE 'COMMON.INTERACT'
1662        INCLUDE 'COMMON.IOUNITS'
1663        INCLUDE 'COMMON.LOCAL'
1664        INCLUDE 'COMMON.NAMES'
1665        INCLUDE 'COMMON.VAR'
1666        double precision scalar
1667        double precision ener(4)
1668        double precision dcosom1(3),dcosom2(3)
1669 c! used in Epol derivatives
1670        double precision facd3, facd4
1671        double precision federmaus, adler
1672 c! Epol and Gpol analytical parameters
1673        alphapol1 = alphapol(itypi,itypj)
1674        alphapol2 = alphapol(itypj,itypi)
1675 c! Fisocav and Gisocav analytical parameters
1676        al1  = alphiso(1,itypi,itypj)
1677        al2  = alphiso(2,itypi,itypj)
1678        al3  = alphiso(3,itypi,itypj)
1679        al4  = alphiso(4,itypi,itypj)
1680        csig = (1.0d0
1681      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1682      &      + sigiso2(itypi,itypj)**2.0d0))
1683 c!
1684        w1   = wqdip(1,itypi,itypj)
1685        w2   = wqdip(2,itypi,itypj)
1686        pis  = sig0head(itypi,itypj)
1687        eps_head = epshead(itypi,itypj)
1688 c! First things first:
1689 c! We need to do sc_grad's job with GB and Fcav
1690        eom1  =
1691      &         eps2der * eps2rt_om1
1692      &       - 2.0D0 * alf1 * eps3der
1693      &       + sigder * sigsq_om1
1694      &       + dCAVdOM1
1695        eom2  =
1696      &         eps2der * eps2rt_om2
1697      &       + 2.0D0 * alf2 * eps3der
1698      &       + sigder * sigsq_om2
1699      &       + dCAVdOM2
1700        eom12 =
1701      &         evdwij  * eps1_om12
1702      &       + eps2der * eps2rt_om12
1703      &       - 2.0D0 * alf12 * eps3der
1704      &       + sigder *sigsq_om12
1705      &       + dCAVdOM12
1706 c! now some magical transformations to project gradient into
1707 c! three cartesian vectors
1708        DO k = 1, 3
1709         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1710         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1711         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
1712 c! this acts on hydrophobic center of interaction
1713         gvdwx(k,i)= gvdwx(k,i) - gg(k)
1714      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1715      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1716         gvdwx(k,j)= gvdwx(k,j) + gg(k)
1717      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1718      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1719 c! this acts on Calpha
1720         gvdwc(k,i)=gvdwc(k,i)-gg(k)
1721         gvdwc(k,j)=gvdwc(k,j)+gg(k)
1722        END DO
1723 c! sc_grad is done, now we will compute
1724        eheadtail = 0.0d0
1725        eom1 = 0.0d0
1726        eom2 = 0.0d0
1727        eom12 = 0.0d0
1728
1729 c! ENERGY DEBUG
1730 c!       ii = 1
1731 c!       jj = 1
1732 c!       d1 = dhead(1, 1, itypi, itypj)
1733 c!       d2 = dhead(2, 1, itypi, itypj)
1734 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1735 c!     &        +dhead(1,ii,itypi,itypj))**2))
1736 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1737 c!     &        +dhead(2,jj,itypi,itypj))**2))
1738 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1739 c! END OF ENERGY DEBUG
1740 c*************************************************************
1741        DO istate = 1, nstate(itypi,itypj)
1742 c*************************************************************
1743         IF (istate.ne.1) THEN
1744          IF (istate.lt.3) THEN
1745           ii = 1
1746          ELSE
1747           ii = 2
1748          END IF
1749         jj = istate/ii
1750         d1 = dhead(1,ii,itypi,itypj)
1751         d2 = dhead(2,jj,itypi,itypj)
1752         DO k = 1,3
1753          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
1754          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
1755          Rhead_distance(k) = chead(k,2) - chead(k,1)
1756         END DO
1757 c! pitagoras (root of sum of squares)
1758         Rhead = dsqrt(
1759      &          (Rhead_distance(1)*Rhead_distance(1))
1760      &        + (Rhead_distance(2)*Rhead_distance(2))
1761      &        + (Rhead_distance(3)*Rhead_distance(3)))
1762         END IF
1763         Rhead_sq = Rhead * Rhead
1764
1765 c! R1 - distance between head of ith side chain and tail of jth sidechain
1766 c! R2 - distance between head of jth side chain and tail of ith sidechain
1767         R1 = 0.0d0
1768         R2 = 0.0d0
1769         DO k = 1, 3
1770 c! Calculate head-to-tail distances
1771          R1=R1+(ctail(k,2)-chead(k,1))**2
1772          R2=R2+(chead(k,2)-ctail(k,1))**2
1773         END DO
1774 c! Pitagoras
1775         R1 = dsqrt(R1)
1776         R2 = dsqrt(R2)
1777
1778 c! ENERGY DEBUG
1779 c!      write (*,*) "istate = ", istate
1780 c!      write (*,*) "ii = ", ii
1781 c!      write (*,*) "jj = ", jj
1782 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1783 c!     &        +dhead(1,ii,itypi,itypj))**2))
1784 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1785 c!     &        +dhead(2,jj,itypi,itypj))**2))
1786 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1787 c!      Rhead_sq = Rhead * Rhead
1788 c!      write (*,*) "d1 = ",d1
1789 c!      write (*,*) "d2 = ",d2
1790 c!      write (*,*) "R1 = ",R1
1791 c!      write (*,*) "R2 = ",R2
1792 c!      write (*,*) "Rhead = ",Rhead
1793 c! END OF ENERGY DEBUG
1794
1795 c!-------------------------------------------------------------------
1796 c! Coulomb electrostatic interaction
1797         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
1798 c!        Ecl = 0.0d0
1799 c!        write (*,*) "Ecl = ", Ecl
1800 c! derivative of Ecl is Gcl...
1801         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
1802 c!        dGCLdR = 0.0d0
1803         dGCLdOM1 = 0.0d0
1804         dGCLdOM2 = 0.0d0
1805         dGCLdOM12 = 0.0d0
1806 c!-------------------------------------------------------------------
1807 c! Generalised Born Solvent Polarization
1808         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1809         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1810         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1811 c!        Egb = 0.0d0
1812 c!      write (*,*) "a1*a2 = ", a12sq
1813 c!      write (*,*) "Rhead = ", Rhead
1814 c!      write (*,*) "Rhead_sq = ", Rhead_sq
1815 c!      write (*,*) "ee = ", ee
1816 c!      write (*,*) "Fgb = ", Fgb
1817 c!      write (*,*) "fac = ", eps_inout_fac
1818 c!      write (*,*) "Qij = ", Qij
1819 c!      write (*,*) "Egb = ", Egb
1820 c! Derivative of Egb is Ggb...
1821 c! dFGBdR is used by Quad's later...
1822         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1823         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1824      &         / ( 2.0d0 * Fgb )
1825         dGGBdR = dGGBdFGB * dFGBdR
1826 c!        dGGBdR = 0.0d0
1827 c!-------------------------------------------------------------------
1828 c! Fisocav - isotropic cavity creation term
1829         pom = Rhead * csig
1830         top = al1 * (dsqrt(pom) + al2 * pom - al3)
1831         bot = (1.0d0 + al4 * pom**12.0d0)
1832         botsq = bot * bot
1833         FisoCav = top / bot
1834 c!        FisoCav = 0.0d0
1835 c!      write (*,*) "pom = ",pom
1836 c!      write (*,*) "al1 = ",al1
1837 c!      write (*,*) "al2 = ",al2
1838 c!      write (*,*) "al3 = ",al3
1839 c!      write (*,*) "al4 = ",al4
1840 c!      write (*,*) "top = ",top
1841 c!      write (*,*) "bot = ",bot
1842 c!      write (*,*) "Fisocav = ", Fisocav
1843
1844 c! Derivative of Fisocav is GCV...
1845         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1846         dbot = 12.0d0 * al4 * pom ** 11.0d0
1847         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1848 c!        dGCVdR = 0.0d0
1849 c!-------------------------------------------------------------------
1850 c! Polarization energy
1851 c! Epol
1852         MomoFac1 = (1.0d0 - chi1 * sqom2)
1853         MomoFac2 = (1.0d0 - chi2 * sqom1)
1854         RR1  = ( R1 * R1 ) / MomoFac1
1855         RR2  = ( R2 * R2 ) / MomoFac2
1856         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1857         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1858         fgb1 = sqrt( RR1 + a12sq * ee1 )
1859         fgb2 = sqrt( RR2 + a12sq * ee2 )
1860         epol = 332.0d0 * eps_inout_fac * (
1861      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1862 c!        epol = 0.0d0
1863 c! derivative of Epol is Gpol...
1864         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1865      &            / (fgb1 ** 5.0d0)
1866         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1867      &            / (fgb2 ** 5.0d0)
1868         dFGBdR1 = ( (R1 / MomoFac1)
1869      &          * ( 2.0d0 - (0.5d0 * ee1) ) )
1870      &          / ( 2.0d0 * fgb1 )
1871         dFGBdR2 = ( (R2 / MomoFac2)
1872      &          * ( 2.0d0 - (0.5d0 * ee2) ) )
1873      &          / ( 2.0d0 * fgb2 )
1874         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1875      &           * ( 2.0d0 - 0.5d0 * ee1) )
1876      &           / ( 2.0d0 * fgb1 )
1877         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1878      &           * ( 2.0d0 - 0.5d0 * ee2) )
1879      &           / ( 2.0d0 * fgb2 )
1880         dPOLdR1 = dPOLdFGB1 * dFGBdR1
1881 c!        dPOLdR1 = 0.0d0
1882         dPOLdR2 = dPOLdFGB2 * dFGBdR2
1883 c!        dPOLdR2 = 0.0d0
1884         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1885 c!        dPOLdOM1 = 0.0d0
1886         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1887 c!        dPOLdOM2 = 0.0d0
1888 c!-------------------------------------------------------------------
1889 c! Elj
1890         pom = (pis / Rhead)**6.0d0
1891         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1892 c!        Elj = 0.0d0
1893 c! derivative of Elj is Glj
1894         dGLJdR = 4.0d0 * eps_head
1895      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1896      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1897 c!        dGLJdR = 0.0d0
1898 c!-------------------------------------------------------------------
1899 c! Equad
1900        IF (Wqd.ne.0.0d0) THEN
1901         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)
1902      &        - 37.5d0  * ( sqom1 + sqom2 )
1903      &        + 157.5d0 * ( sqom1 * sqom2 )
1904      &        - 45.0d0  * om1*om2*om12
1905         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
1906         Equad = fac * Beta1
1907 c!        Equad = 0.0d0
1908 c! derivative of Equad...
1909         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
1910 c!        dQUADdR = 0.0d0
1911         dQUADdOM1 = fac
1912      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
1913 c!        dQUADdOM1 = 0.0d0
1914         dQUADdOM2 = fac
1915      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
1916 c!        dQUADdOM2 = 0.0d0
1917         dQUADdOM12 = fac
1918      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )
1919 c!        dQUADdOM12 = 0.0d0
1920         ELSE
1921          Beta1 = 0.0d0
1922          Equad = 0.0d0
1923         END IF
1924 c!-------------------------------------------------------------------
1925 c! Return the results
1926 c! Angular stuff
1927         eom1 = dPOLdOM1 + dQUADdOM1
1928         eom2 = dPOLdOM2 + dQUADdOM2
1929         eom12 = dQUADdOM12
1930 c! now some magical transformations to project gradient into
1931 c! three cartesian vectors
1932         DO k = 1, 3
1933          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1934          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1935          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
1936         END DO
1937 c! Radial stuff
1938         DO k = 1, 3
1939          erhead(k) = Rhead_distance(k)/Rhead
1940          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1941          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1942         END DO
1943         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1944         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1945         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1946         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1947         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1948         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1949         facd1 = d1 * vbld_inv(i+nres)
1950         facd2 = d2 * vbld_inv(j+nres)
1951         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1952         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1953 c! Throw the results into gheadtail which holds gradients
1954 c! for each micro-state
1955         DO k = 1, 3
1956          hawk   = erhead_tail(k,1) +
1957      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
1958          condor = erhead_tail(k,2) +
1959      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
1960
1961          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1962 c! this acts on hydrophobic center of interaction
1963          gheadtail(k,1,1) = gheadtail(k,1,1)
1964      &                    - dGCLdR * pom
1965      &                    - dGGBdR * pom
1966      &                    - dGCVdR * pom
1967      &                    - dPOLdR1 * hawk
1968      &                    - dPOLdR2 * (erhead_tail(k,2)
1969      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1970      &                    - dGLJdR * pom
1971      &                    - dQUADdR * pom
1972      &                    - tuna(k)
1973      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1974      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1975
1976          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1977 c! this acts on hydrophobic center of interaction
1978          gheadtail(k,2,1) = gheadtail(k,2,1)
1979      &                    + dGCLdR * pom
1980      &                    + dGGBdR * pom
1981      &                    + dGCVdR * pom
1982      &                    + dPOLdR1 * (erhead_tail(k,1)
1983      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1984      &                    + dPOLdR2 * condor
1985      &                    + dGLJdR * pom
1986      &                    + dQUADdR * pom
1987      &                    + tuna(k)
1988      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1989      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1990
1991 c! this acts on Calpha
1992          gheadtail(k,3,1) = gheadtail(k,3,1)
1993      &                    - dGCLdR * erhead(k)
1994      &                    - dGGBdR * erhead(k)
1995      &                    - dGCVdR * erhead(k)
1996      &                    - dPOLdR1 * erhead_tail(k,1)
1997      &                    - dPOLdR2 * erhead_tail(k,2)
1998      &                    - dGLJdR * erhead(k)
1999      &                    - dQUADdR * erhead(k)
2000      &                    - tuna(k)
2001
2002 c! this acts on Calpha
2003          gheadtail(k,4,1) = gheadtail(k,4,1)
2004      &                    + dGCLdR * erhead(k)
2005      &                    + dGGBdR * erhead(k)
2006      &                    + dGCVdR * erhead(k)
2007      &                    + dPOLdR1 * erhead_tail(k,1)
2008      &                    + dPOLdR2 * erhead_tail(k,2)
2009      &                    + dGLJdR * erhead(k)
2010      &                    + dQUADdR * erhead(k)
2011      &                    + tuna(k)
2012         END DO
2013 c!      write(*,*) "ECL = ", Ecl
2014 c!      write(*,*) "Egb = ", Egb
2015 c!      write(*,*) "Epol = ", Epol
2016 c!      write(*,*) "Fisocav = ", Fisocav
2017 c!      write(*,*) "Elj = ", Elj
2018 c!      write(*,*) "Equad = ", Equad
2019 c!      write(*,*) "wstate = ", wstate(istate,itypi,itypj)
2020 c!      write(*,*) "eheadtail = ", eheadtail
2021 c!      write(*,*) "TROLL = ", dexp(-betaT * ener(istate))
2022 c!      write(*,*) "dGCLdR = ", dGCLdR
2023 c!      write(*,*) "dGGBdR = ", dGGBdR
2024 c!      write(*,*) "dGCVdR = ", dGCVdR
2025 c!      write(*,*) "dPOLdR1 = ", dPOLdR1
2026 c!      write(*,*) "dPOLdR2 = ", dPOLdR2
2027 c!      write(*,*) "dGLJdR = ", dGLJdR
2028 c!      write(*,*) "dQUADdR = ", dQUADdR
2029 c!      write(*,*) "tuna(",k,") = ", tuna(k)
2030         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
2031         eheadtail = eheadtail
2032      &            + wstate(istate, itypi, itypj)
2033      &            * dexp(-betaT * ener(istate))
2034 c! foreach cartesian dimension
2035         DO k = 1, 3
2036 c! foreach of two gvdwx and gvdwc
2037          DO l = 1, 4
2038           gheadtail(k,l,2) = gheadtail(k,l,2)
2039      &                     + wstate( istate, itypi, itypj )
2040      &                     * dexp(-betaT * ener(istate))
2041      &                     * gheadtail(k,l,1)
2042           gheadtail(k,l,1) = 0.0d0
2043          END DO
2044         END DO
2045        END DO
2046 c! Here ended the gigantic DO istate = 1, 4, which starts
2047 c! at the beggining of the subroutine
2048
2049        DO k = 1, 3
2050         DO l = 1, 4
2051          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
2052         END DO
2053         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
2054         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
2055         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
2056         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
2057         DO l = 1, 4
2058          gheadtail(k,l,1) = 0.0d0
2059          gheadtail(k,l,2) = 0.0d0
2060         END DO
2061        END DO
2062        eheadtail = (-dlog(eheadtail)) / betaT
2063        dPOLdOM1 = 0.0d0
2064        dPOLdOM2 = 0.0d0
2065        dQUADdOM1 = 0.0d0
2066        dQUADdOM2 = 0.0d0
2067        dQUADdOM12 = 0.0d0
2068        RETURN
2069       END SUBROUTINE energy_quad
2070
2071
2072 c!-------------------------------------------------------------------
2073
2074
2075       SUBROUTINE eqn(Epol)
2076       IMPLICIT NONE
2077       INCLUDE 'DIMENSIONS'
2078       INCLUDE 'DIMENSIONS.ZSCOPT'
2079       INCLUDE 'COMMON.CALC'
2080       INCLUDE 'COMMON.CHAIN'
2081       INCLUDE 'COMMON.CONTROL'
2082       INCLUDE 'COMMON.DERIV'
2083       INCLUDE 'COMMON.EMP'
2084       INCLUDE 'COMMON.GEO'
2085       INCLUDE 'COMMON.INTERACT'
2086       INCLUDE 'COMMON.IOUNITS'
2087       INCLUDE 'COMMON.LOCAL'
2088       INCLUDE 'COMMON.NAMES'
2089       INCLUDE 'COMMON.VAR'
2090       double precision scalar, facd4, federmaus
2091       alphapol1 = alphapol(itypi,itypj)
2092 c! R1 - distance between head of ith side chain and tail of jth sidechain
2093        R1 = 0.0d0
2094        DO k = 1, 3
2095 c! Calculate head-to-tail distances
2096         R1=R1+(ctail(k,2)-chead(k,1))**2
2097        END DO
2098 c! Pitagoras
2099        R1 = dsqrt(R1)
2100
2101 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2102 c!     &        +dhead(1,1,itypi,itypj))**2))
2103 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2104 c!     &        +dhead(2,1,itypi,itypj))**2))
2105 c--------------------------------------------------------------------
2106 c Polarization energy
2107 c Epol
2108        MomoFac1 = (1.0d0 - chi1 * sqom2)
2109        RR1  = R1 * R1 / MomoFac1
2110        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2111        fgb1 = sqrt( RR1 + a12sq * ee1)
2112        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2113 c!       epol = 0.0d0
2114 c!------------------------------------------------------------------
2115 c! derivative of Epol is Gpol...
2116        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2117      &          / (fgb1 ** 5.0d0)
2118        dFGBdR1 = ( (R1 / MomoFac1)
2119      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2120      &        / ( 2.0d0 * fgb1 )
2121        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2122      &          * (2.0d0 - 0.5d0 * ee1) )
2123      &          / (2.0d0 * fgb1)
2124        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2125 c!       dPOLdR1 = 0.0d0
2126        dPOLdOM1 = 0.0d0
2127        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2128 c!       dPOLdOM2 = 0.0d0
2129 c!-------------------------------------------------------------------
2130 c! Return the results
2131 c! (see comments in Eqq)
2132        DO k = 1, 3
2133         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2134        END DO
2135        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2136        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2137        facd1 = d1 * vbld_inv(i+nres)
2138        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2139
2140        DO k = 1, 3
2141         hawk = (erhead_tail(k,1) +
2142      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2143
2144         gvdwx(k,i) = gvdwx(k,i)
2145      &             - dPOLdR1 * hawk
2146         gvdwx(k,j) = gvdwx(k,j)
2147      &             + dPOLdR1 * (erhead_tail(k,1)
2148      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2149
2150         gvdwc(k,i) = gvdwc(k,i)
2151      &             - dPOLdR1 * erhead_tail(k,1)
2152         gvdwc(k,j) = gvdwc(k,j)
2153      &             + dPOLdR1 * erhead_tail(k,1)
2154
2155        END DO
2156        RETURN
2157       END SUBROUTINE eqn
2158
2159
2160 c!-------------------------------------------------------------------
2161
2162
2163
2164       SUBROUTINE enq(Epol)
2165        IMPLICIT NONE
2166        INCLUDE 'DIMENSIONS'
2167        INCLUDE 'DIMENSIONS.ZSCOPT'
2168        INCLUDE 'COMMON.CALC'
2169        INCLUDE 'COMMON.CHAIN'
2170        INCLUDE 'COMMON.CONTROL'
2171        INCLUDE 'COMMON.DERIV'
2172        INCLUDE 'COMMON.EMP'
2173        INCLUDE 'COMMON.GEO'
2174        INCLUDE 'COMMON.INTERACT'
2175        INCLUDE 'COMMON.IOUNITS'
2176        INCLUDE 'COMMON.LOCAL'
2177        INCLUDE 'COMMON.NAMES'
2178        INCLUDE 'COMMON.VAR'
2179        double precision scalar, facd3, adler
2180        alphapol2 = alphapol(itypj,itypi)
2181 c! R2 - distance between head of jth side chain and tail of ith sidechain
2182        R2 = 0.0d0
2183        DO k = 1, 3
2184 c! Calculate head-to-tail distances
2185         R2=R2+(chead(k,2)-ctail(k,1))**2
2186        END DO
2187 c! Pitagoras
2188        R2 = dsqrt(R2)
2189
2190 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2191 c!     &        +dhead(1,1,itypi,itypj))**2))
2192 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2193 c!     &        +dhead(2,1,itypi,itypj))**2))
2194 c------------------------------------------------------------------------
2195 c Polarization energy
2196        MomoFac2 = (1.0d0 - chi2 * sqom1)
2197        RR2  = R2 * R2 / MomoFac2
2198        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2199        fgb2 = sqrt(RR2  + a12sq * ee2)
2200        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2201 c!       epol = 0.0d0
2202 c!-------------------------------------------------------------------
2203 c! derivative of Epol is Gpol...
2204        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2205      &          / (fgb2 ** 5.0d0)
2206        dFGBdR2 = ( (R2 / MomoFac2)
2207      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2208      &        / (2.0d0 * fgb2)
2209        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2210      &          * (2.0d0 - 0.5d0 * ee2) )
2211      &          / (2.0d0 * fgb2)
2212        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2213 c!       dPOLdR2 = 0.0d0
2214        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2215 c!       dPOLdOM1 = 0.0d0
2216        dPOLdOM2 = 0.0d0
2217 c!-------------------------------------------------------------------
2218 c! Return the results
2219 c! (See comments in Eqq)
2220        DO k = 1, 3
2221         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2222        END DO
2223        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2224        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2225        facd2 = d2 * vbld_inv(j+nres)
2226        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2227        DO k = 1, 3
2228         condor = (erhead_tail(k,2)
2229      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2230
2231         gvdwx(k,i) = gvdwx(k,i)
2232      &             - dPOLdR2 * (erhead_tail(k,2)
2233      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2234         gvdwx(k,j) = gvdwx(k,j)
2235      &             + dPOLdR2 * condor
2236
2237         gvdwc(k,i) = gvdwc(k,i)
2238      &             - dPOLdR2 * erhead_tail(k,2)
2239         gvdwc(k,j) = gvdwc(k,j)
2240      &             + dPOLdR2 * erhead_tail(k,2)
2241
2242        END DO
2243       RETURN
2244       END SUBROUTINE enq
2245
2246
2247 c!-------------------------------------------------------------------
2248
2249
2250       SUBROUTINE eqd(Ecl,Elj,Epol)
2251        IMPLICIT NONE
2252        INCLUDE 'DIMENSIONS'
2253        INCLUDE 'DIMENSIONS.ZSCOPT'
2254        INCLUDE 'COMMON.CALC'
2255        INCLUDE 'COMMON.CHAIN'
2256        INCLUDE 'COMMON.CONTROL'
2257        INCLUDE 'COMMON.DERIV'
2258        INCLUDE 'COMMON.EMP'
2259        INCLUDE 'COMMON.GEO'
2260        INCLUDE 'COMMON.INTERACT'
2261        INCLUDE 'COMMON.IOUNITS'
2262        INCLUDE 'COMMON.LOCAL'
2263        INCLUDE 'COMMON.NAMES'
2264        INCLUDE 'COMMON.VAR'
2265        double precision scalar, facd4, federmaus
2266        alphapol1 = alphapol(itypi,itypj)
2267        w1        = wqdip(1,itypi,itypj)
2268        w2        = wqdip(2,itypi,itypj)
2269        pis       = sig0head(itypi,itypj)
2270        eps_head   = epshead(itypi,itypj)
2271 c!-------------------------------------------------------------------
2272 c! R1 - distance between head of ith side chain and tail of jth sidechain
2273        R1 = 0.0d0
2274        DO k = 1, 3
2275 c! Calculate head-to-tail distances
2276         R1=R1+(ctail(k,2)-chead(k,1))**2
2277        END DO
2278 c! Pitagoras
2279        R1 = dsqrt(R1)
2280
2281 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2282 c!     &        +dhead(1,1,itypi,itypj))**2))
2283 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2284 c!     &        +dhead(2,1,itypi,itypj))**2))
2285
2286 c!-------------------------------------------------------------------
2287 c! ecl
2288        sparrow  = w1 * Qi * om1
2289        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2290        Ecl = sparrow / Rhead**2.0d0
2291      &     - hawk    / Rhead**4.0d0
2292 c!-------------------------------------------------------------------
2293 c! derivative of ecl is Gcl
2294 c! dF/dr part
2295        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2296      &           + 4.0d0 * hawk    / Rhead**5.0d0
2297 c! dF/dom1
2298        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2299 c! dF/dom2
2300        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2301 c--------------------------------------------------------------------
2302 c Polarization energy
2303 c Epol
2304        MomoFac1 = (1.0d0 - chi1 * sqom2)
2305        RR1  = R1 * R1 / MomoFac1
2306        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2307        fgb1 = sqrt( RR1 + a12sq * ee1)
2308        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2309 c!       epol = 0.0d0
2310 c!------------------------------------------------------------------
2311 c! derivative of Epol is Gpol...
2312        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2313      &          / (fgb1 ** 5.0d0)
2314        dFGBdR1 = ( (R1 / MomoFac1)
2315      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2316      &        / ( 2.0d0 * fgb1 )
2317        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2318      &          * (2.0d0 - 0.5d0 * ee1) )
2319      &          / (2.0d0 * fgb1)
2320        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2321 c!       dPOLdR1 = 0.0d0
2322        dPOLdOM1 = 0.0d0
2323        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2324 c!       dPOLdOM2 = 0.0d0
2325 c!-------------------------------------------------------------------
2326 c! Elj
2327        pom = (pis / Rhead)**6.0d0
2328        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2329 c! derivative of Elj is Glj
2330        dGLJdR = 4.0d0 * eps_head
2331      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2332      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2333 c!-------------------------------------------------------------------
2334 c! Return the results
2335        DO k = 1, 3
2336         erhead(k) = Rhead_distance(k)/Rhead
2337         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2338        END DO
2339
2340        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2341        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2342        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2343        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2344        facd1 = d1 * vbld_inv(i+nres)
2345        facd2 = d2 * vbld_inv(j+nres)
2346        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2347
2348        DO k = 1, 3
2349         hawk = (erhead_tail(k,1) +
2350      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2351
2352         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2353         gvdwx(k,i) = gvdwx(k,i)
2354      &             - dGCLdR * pom
2355      &             - dPOLdR1 * hawk
2356      &             - dGLJdR * pom
2357
2358         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2359         gvdwx(k,j) = gvdwx(k,j)
2360      &             + dGCLdR * pom
2361      &             + dPOLdR1 * (erhead_tail(k,1)
2362      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2363      &             + dGLJdR * pom
2364
2365
2366         gvdwc(k,i) = gvdwc(k,i)
2367      &             - dGCLdR * erhead(k)
2368      &             - dPOLdR1 * erhead_tail(k,1)
2369      &             - dGLJdR * erhead(k)
2370
2371         gvdwc(k,j) = gvdwc(k,j)
2372      &             + dGCLdR * erhead(k)
2373      &             + dPOLdR1 * erhead_tail(k,1)
2374      &             + dGLJdR * erhead(k)
2375
2376        END DO
2377        RETURN
2378       END SUBROUTINE eqd
2379
2380
2381 c!-------------------------------------------------------------------
2382
2383
2384       SUBROUTINE edq(Ecl,Elj,Epol)
2385        IMPLICIT NONE
2386        INCLUDE 'DIMENSIONS'
2387        INCLUDE 'DIMENSIONS.ZSCOPT'
2388        INCLUDE 'COMMON.CALC'
2389        INCLUDE 'COMMON.CHAIN'
2390        INCLUDE 'COMMON.CONTROL'
2391        INCLUDE 'COMMON.DERIV'
2392        INCLUDE 'COMMON.EMP'
2393        INCLUDE 'COMMON.GEO'
2394        INCLUDE 'COMMON.INTERACT'
2395        INCLUDE 'COMMON.IOUNITS'
2396        INCLUDE 'COMMON.LOCAL'
2397        INCLUDE 'COMMON.NAMES'
2398        INCLUDE 'COMMON.VAR'
2399        double precision scalar, facd3, adler
2400        alphapol2 = alphapol(itypj,itypi)
2401        w1        = wqdip(1,itypi,itypj)
2402        w2        = wqdip(2,itypi,itypj)
2403        pis       = sig0head(itypi,itypj)
2404        eps_head  = epshead(itypi,itypj)
2405 c!-------------------------------------------------------------------
2406 c! R2 - distance between head of jth side chain and tail of ith sidechain
2407        R2 = 0.0d0
2408        DO k = 1, 3
2409 c! Calculate head-to-tail distances
2410         R2=R2+(chead(k,2)-ctail(k,1))**2
2411        END DO
2412 c! Pitagoras
2413        R2 = dsqrt(R2)
2414
2415 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2416 c!     &        +dhead(1,1,itypi,itypj))**2))
2417 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2418 c!     &        +dhead(2,1,itypi,itypj))**2))
2419
2420
2421 c!-------------------------------------------------------------------
2422 c! ecl
2423        sparrow  = w1 * Qi * om1
2424        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2425        ECL = sparrow / Rhead**2.0d0
2426      &     - hawk    / Rhead**4.0d0
2427 c!-------------------------------------------------------------------
2428 c! derivative of ecl is Gcl
2429 c! dF/dr part
2430        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2431      &           + 4.0d0 * hawk    / Rhead**5.0d0
2432 c! dF/dom1
2433        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2434 c! dF/dom2
2435        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2436 c--------------------------------------------------------------------
2437 c Polarization energy
2438 c Epol
2439        MomoFac2 = (1.0d0 - chi2 * sqom1)
2440        RR2  = R2 * R2 / MomoFac2
2441        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2442        fgb2 = sqrt(RR2  + a12sq * ee2)
2443        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2444 c!       epol = 0.0d0
2445 c! derivative of Epol is Gpol...
2446        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2447      &          / (fgb2 ** 5.0d0)
2448        dFGBdR2 = ( (R2 / MomoFac2)
2449      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2450      &        / (2.0d0 * fgb2)
2451        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2452      &          * (2.0d0 - 0.5d0 * ee2) )
2453      &          / (2.0d0 * fgb2)
2454        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2455 c!       dPOLdR2 = 0.0d0
2456        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2457 c!       dPOLdOM1 = 0.0d0
2458        dPOLdOM2 = 0.0d0
2459 c!-------------------------------------------------------------------
2460 c! Elj
2461        pom = (pis / Rhead)**6.0d0
2462        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2463 c! derivative of Elj is Glj
2464        dGLJdR = 4.0d0 * eps_head
2465      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2466      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2467 c!-------------------------------------------------------------------
2468 c! Return the results
2469 c! (see comments in Eqq)
2470        DO k = 1, 3
2471         erhead(k) = Rhead_distance(k)/Rhead
2472         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2473        END DO
2474        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2475        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2476        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2477        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2478        facd1 = d1 * vbld_inv(i+nres)
2479        facd2 = d2 * vbld_inv(j+nres)
2480        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2481
2482        DO k = 1, 3
2483         condor = (erhead_tail(k,2)
2484      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2485
2486         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2487         gvdwx(k,i) = gvdwx(k,i)
2488      &             - dGCLdR * pom
2489      &             - dPOLdR2 * (erhead_tail(k,2)
2490      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2491      &             - dGLJdR * pom
2492
2493         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2494         gvdwx(k,j) = gvdwx(k,j)
2495      &             + dGCLdR * pom
2496      &             + dPOLdR2 * condor
2497      &             + dGLJdR * pom
2498
2499
2500         gvdwc(k,i) = gvdwc(k,i)
2501      &             - dGCLdR * erhead(k)
2502      &             - dPOLdR2 * erhead_tail(k,2)
2503      &             - dGLJdR * erhead(k)
2504
2505         gvdwc(k,j) = gvdwc(k,j)
2506      &             + dGCLdR * erhead(k)
2507      &             + dPOLdR2 * erhead_tail(k,2)
2508      &             + dGLJdR * erhead(k)
2509
2510        END DO
2511        RETURN
2512       END SUBROUTINE edq
2513
2514
2515 C--------------------------------------------------------------------
2516
2517
2518       SUBROUTINE edd(ECL)
2519        IMPLICIT NONE
2520        INCLUDE 'DIMENSIONS'
2521        INCLUDE 'DIMENSIONS.ZSCOPT'
2522        INCLUDE 'COMMON.CALC'
2523        INCLUDE 'COMMON.CHAIN'
2524        INCLUDE 'COMMON.CONTROL'
2525        INCLUDE 'COMMON.DERIV'
2526        INCLUDE 'COMMON.EMP'
2527        INCLUDE 'COMMON.GEO'
2528        INCLUDE 'COMMON.INTERACT'
2529        INCLUDE 'COMMON.IOUNITS'
2530        INCLUDE 'COMMON.LOCAL'
2531        INCLUDE 'COMMON.NAMES'
2532        INCLUDE 'COMMON.VAR'
2533        double precision scalar
2534 c!       csig = sigiso(itypi,itypj)
2535        w1 = wqdip(1,itypi,itypj)
2536        w2 = wqdip(2,itypi,itypj)
2537 c!-------------------------------------------------------------------
2538 c! ECL
2539        fac = (om12 - 3.0d0 * om1 * om2)
2540        c1 = (w1 / (Rhead**3.0d0)) * fac
2541        c2 = (w2 / Rhead ** 6.0d0)
2542      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2543        ECL = c1 - c2
2544 c!       write (*,*) "w1 = ", w1
2545 c!       write (*,*) "w2 = ", w2
2546 c!       write (*,*) "om1 = ", om1
2547 c!       write (*,*) "om2 = ", om2
2548 c!       write (*,*) "om12 = ", om12
2549 c!       write (*,*) "fac = ", fac
2550 c!       write (*,*) "c1 = ", c1
2551 c!       write (*,*) "c2 = ", c2
2552 c!       write (*,*) "Ecl = ", Ecl
2553 c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
2554 c!       write (*,*) "c2_2 = ",
2555 c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2556 c!-------------------------------------------------------------------
2557 c! dervative of ECL is GCL...
2558 c! dECL/dr
2559        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
2560        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)
2561      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
2562        dGCLdR = c1 - c2
2563 c! dECL/dom1
2564        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
2565        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2566      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
2567        dGCLdOM1 = c1 - c2
2568 c! dECL/dom2
2569        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
2570        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2571      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
2572        dGCLdOM2 = c1 - c2
2573 c! dECL/dom12
2574        c1 = w1 / (Rhead ** 3.0d0)
2575        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
2576        dGCLdOM12 = c1 - c2
2577 c!-------------------------------------------------------------------
2578 c! Return the results
2579 c! (see comments in Eqq)
2580        DO k= 1, 3
2581         erhead(k) = Rhead_distance(k)/Rhead
2582        END DO
2583        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2584        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2585        facd1 = d1 * vbld_inv(i+nres)
2586        facd2 = d2 * vbld_inv(j+nres)
2587        DO k = 1, 3
2588
2589         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2590         gvdwx(k,i) = gvdwx(k,i)
2591      &             - dGCLdR * pom
2592         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2593         gvdwx(k,j) = gvdwx(k,j)
2594      &             + dGCLdR * pom
2595
2596         gvdwc(k,i) = gvdwc(k,i)
2597      &             - dGCLdR * erhead(k)
2598         gvdwc(k,j) = gvdwc(k,j)
2599      &             + dGCLdR * erhead(k)
2600        END DO
2601        RETURN
2602       END SUBROUTINE edd
2603
2604
2605 c!-------------------------------------------------------------------
2606
2607
2608       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
2609        IMPLICIT NONE
2610 c! maxres
2611        INCLUDE 'DIMENSIONS'
2612 c! itypi, itypj, i, j, k, l, chead,
2613        INCLUDE 'COMMON.CALC'
2614 c! c, nres, dc_norm
2615        INCLUDE 'COMMON.CHAIN'
2616 c! gradc, gradx
2617        INCLUDE 'COMMON.DERIV'
2618 c! electrostatic gradients-specific variables
2619        INCLUDE 'COMMON.EMP'
2620 c! wquad, dhead, alphiso, alphasur, rborn, epsintab
2621        INCLUDE 'COMMON.INTERACT'
2622 c! io for debug, disable it in final builds
2623        INCLUDE 'COMMON.IOUNITS'
2624 c!-------------------------------------------------------------------
2625 c! Variable Init
2626
2627 c! what amino acid is the aminoacid j'th?
2628        itypj = itype(j)
2629 c! 1/(Gas Constant * Thermostate temperature) = BetaT
2630 c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
2631        BetaT = 1.0d0 / (298 * 1.987d-3)
2632 c! Gay-berne var's
2633        sig0ij = sigma( itypi,itypj )
2634        chi1   = chi( itypi, itypj )
2635        chi2   = chi( itypj, itypi )
2636        chi12  = chi1 * chi2
2637        chip1  = chipp( itypi, itypj )
2638        chip2  = chipp( itypj, itypi )
2639        chip12 = chip1 * chip2
2640 c!       write (2,*) "elgrad types",itypi,itypj,
2641 c!     & " chi1",chi1," chi2",chi2," chi12",chi12,
2642 c!     &  " chip1",chip1," chip2",chip2," chip12",chip12
2643 c! not used by momo potential, but needed by sc_angular which is shared
2644 c! by all energy_potential subroutines
2645        alf1   = 0.0d0
2646        alf2   = 0.0d0
2647        alf12  = 0.0d0
2648 c! location, location, location
2649        xj  = c( 1, nres+j ) - xi
2650        yj  = c( 2, nres+j ) - yi
2651        zj  = c( 3, nres+j ) - zi
2652        dxj = dc_norm( 1, nres+j )
2653        dyj = dc_norm( 2, nres+j )
2654        dzj = dc_norm( 3, nres+j )
2655 c! distance from center of chain(?) to polar/charged head
2656 c!       write (*,*) "istate = ", 1
2657 c!       write (*,*) "ii = ", 1
2658 c!       write (*,*) "jj = ", 1
2659        d1 = dhead(1, 1, itypi, itypj)
2660        d2 = dhead(2, 1, itypi, itypj)
2661 c! ai*aj from Fgb
2662        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
2663 c!       a12sq = a12sq * a12sq
2664 c! charge of amino acid itypi is...
2665        Qi  = icharge(itypi)
2666        Qj  = icharge(itypj)
2667        Qij = Qi * Qj
2668 c! chis1,2,12
2669        chis1 = chis(itypi,itypj)
2670        chis2 = chis(itypj,itypi)
2671        chis12 = chis1 * chis2
2672        sig1 = sigmap1(itypi,itypj)
2673        sig2 = sigmap2(itypi,itypj)
2674 c!       write (*,*) "sig1 = ", sig1
2675 c!       write (*,*) "sig2 = ", sig2
2676 c! alpha factors from Fcav/Gcav
2677        b1 = alphasur(1,itypi,itypj)
2678        b2 = alphasur(2,itypi,itypj)
2679        b3 = alphasur(3,itypi,itypj)
2680        b4 = alphasur(4,itypi,itypj)
2681 c! used to determine whether we want to do quadrupole calculations
2682        wqd = wquad(itypi, itypj)
2683 c! used by Fgb
2684        eps_in = epsintab(itypi,itypj)
2685        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
2686 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
2687 c!-------------------------------------------------------------------
2688 c! tail location and distance calculations
2689        Rtail = 0.0d0
2690        DO k = 1, 3
2691         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
2692         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
2693        END DO
2694 c! tail distances will be themselves usefull elswhere
2695 c1 (in Gcav, for example)
2696        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
2697        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
2698        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
2699        Rtail = dsqrt(
2700      &     (Rtail_distance(1)*Rtail_distance(1))
2701      &   + (Rtail_distance(2)*Rtail_distance(2))
2702      &   + (Rtail_distance(3)*Rtail_distance(3)))
2703 c!-------------------------------------------------------------------
2704 c! Calculate location and distance between polar heads
2705 c! distance between heads
2706 c! for each one of our three dimensional space...
2707        DO k = 1,3
2708 c! location of polar head is computed by taking hydrophobic centre
2709 c! and moving by a d1 * dc_norm vector
2710 c! see unres publications for very informative images
2711         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
2712         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
2713 c! distance
2714 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
2715 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
2716         Rhead_distance(k) = chead(k,2) - chead(k,1)
2717        END DO
2718 c! pitagoras (root of sum of squares)
2719        Rhead = dsqrt(
2720      &     (Rhead_distance(1)*Rhead_distance(1))
2721      &   + (Rhead_distance(2)*Rhead_distance(2))
2722      &   + (Rhead_distance(3)*Rhead_distance(3)))
2723 c!-------------------------------------------------------------------
2724 c! zero everything that should be zero'ed
2725        Egb = 0.0d0
2726        ECL = 0.0d0
2727        Elj = 0.0d0
2728        Equad = 0.0d0
2729        Epol = 0.0d0
2730        eheadtail = 0.0d0
2731        dGCLdOM1 = 0.0d0
2732        dGCLdOM2 = 0.0d0
2733        dGCLdOM12 = 0.0d0
2734        dPOLdOM1 = 0.0d0
2735        dPOLdOM2 = 0.0d0
2736        RETURN
2737       END SUBROUTINE elgrad_init
2738 c!-------------------------------------------------------------------
2739       subroutine sc_angular
2740 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2741 C om12. Called by ebp, egb, and egbv.
2742       implicit none
2743       include 'COMMON.CALC'
2744       include 'COMMON.IOUNITS'
2745       erij(1)=xj*rij
2746       erij(2)=yj*rij
2747       erij(3)=zj*rij
2748       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2749       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2750       om12=dxi*dxj+dyi*dyj+dzi*dzj
2751 c!      om1    = 0.0d0
2752 c!      om2    = 0.0d0
2753 c!      om12   = 0.0d0
2754       chiom12=chi12*om12
2755 C Calculate eps1(om12) and its derivative in om12
2756       faceps1=1.0D0-om12*chiom12
2757       faceps1_inv=1.0D0/faceps1
2758       eps1=dsqrt(faceps1_inv)
2759 c      write (2,*) "chi1",chi1," chi2",chi2," chi12",chi12
2760 c      write (2,*) "fsceps1",faceps1," faceps1_inv",faceps1_inv,
2761 c     & " eps1",eps1
2762 C Following variable is eps1*deps1/dom12
2763       eps1_om12=faceps1_inv*chiom12
2764 c diagnostics only
2765 c      faceps1_inv=om12
2766 c      eps1=om12
2767 c      eps1_om12=1.0d0
2768 c      write (iout,*) "om12",om12," eps1",eps1
2769 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2770 C and om12.
2771       om1om2=om1*om2
2772       chiom1=chi1*om1
2773       chiom2=chi2*om2
2774       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2775       sigsq=1.0D0-facsig*faceps1_inv
2776 c      write (2,*) "om1",om1," om2",om2," om1om2",om1om2,
2777 c     & " chiom1",chiom1,
2778 c     &  " chiom2",chiom2," facsig",facsig," sigsq",sigsq
2779       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2780       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2781       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2782 c diagnostics only
2783 c      sigsq=1.0d0
2784 c      sigsq_om1=0.0d0
2785 c      sigsq_om2=0.0d0
2786 c      sigsq_om12=0.0d0
2787 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2788 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2789 c     &    " eps1",eps1
2790 C Calculate eps2 and its derivatives in om1, om2, and om12.
2791       chipom1=chip1*om1
2792       chipom2=chip2*om2
2793       chipom12=chip12*om12
2794       facp=1.0D0-om12*chipom12
2795       facp_inv=1.0D0/facp
2796       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2797 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2798 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2799 C Following variable is the square root of eps2
2800       eps2rt=1.0D0-facp1*facp_inv
2801 C Following three variables are the derivatives of the square root of eps
2802 C in om1, om2, and om12.
2803       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2804       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2805       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2806 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2807 c! Note that THIS is 0 in emomo, so we should probably move it out of sc_angular
2808 c! Or frankly, we should restructurize the whole energy section
2809       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2810 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2811 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2812 c     &  " eps2rt_om12",eps2rt_om12
2813 C Calculate whole angle-dependent part of epsilon and contributions
2814 C to its derivatives
2815       return
2816       end
2817 C----------------------------------------------------------------------------
2818       subroutine sc_grad
2819       implicit real*8 (a-h,o-z)
2820       include 'DIMENSIONS'
2821       include 'DIMENSIONS.ZSCOPT'
2822       include 'COMMON.CHAIN'
2823       include 'COMMON.DERIV'
2824       include 'COMMON.CALC'
2825       double precision dcosom1(3),dcosom2(3)
2826       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2827       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2828       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2829      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2830       do k=1,3
2831         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2832         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2833       enddo
2834       do k=1,3
2835         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2836       enddo
2837       do k=1,3
2838         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2839      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2840      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2841         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2842      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2843      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2844       enddo
2845 C
2846 C Calculate the components of the gradient in DC and X
2847 C
2848       do k=i,j-1
2849         do l=1,3
2850           gvdwc(l,k)=gvdwc(l,k)+gg(l)
2851         enddo
2852       enddo
2853       return
2854       end
2855 c------------------------------------------------------------------------------
2856       subroutine vec_and_deriv
2857       implicit real*8 (a-h,o-z)
2858       include 'DIMENSIONS'
2859       include 'DIMENSIONS.ZSCOPT'
2860       include 'COMMON.IOUNITS'
2861       include 'COMMON.GEO'
2862       include 'COMMON.VAR'
2863       include 'COMMON.LOCAL'
2864       include 'COMMON.CHAIN'
2865       include 'COMMON.VECTORS'
2866       include 'COMMON.DERIV'
2867       include 'COMMON.INTERACT'
2868       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2869 C Compute the local reference systems. For reference system (i), the
2870 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2871 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2872       do i=1,nres-1
2873 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
2874           if (i.eq.nres-1) then
2875 C Case of the last full residue
2876 C Compute the Z-axis
2877             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2878             costh=dcos(pi-theta(nres))
2879             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2880             do k=1,3
2881               uz(k,i)=fac*uz(k,i)
2882             enddo
2883             if (calc_grad) then
2884 C Compute the derivatives of uz
2885             uzder(1,1,1)= 0.0d0
2886             uzder(2,1,1)=-dc_norm(3,i-1)
2887             uzder(3,1,1)= dc_norm(2,i-1)
2888             uzder(1,2,1)= dc_norm(3,i-1)
2889             uzder(2,2,1)= 0.0d0
2890             uzder(3,2,1)=-dc_norm(1,i-1)
2891             uzder(1,3,1)=-dc_norm(2,i-1)
2892             uzder(2,3,1)= dc_norm(1,i-1)
2893             uzder(3,3,1)= 0.0d0
2894             uzder(1,1,2)= 0.0d0
2895             uzder(2,1,2)= dc_norm(3,i)
2896             uzder(3,1,2)=-dc_norm(2,i)
2897             uzder(1,2,2)=-dc_norm(3,i)
2898             uzder(2,2,2)= 0.0d0
2899             uzder(3,2,2)= dc_norm(1,i)
2900             uzder(1,3,2)= dc_norm(2,i)
2901             uzder(2,3,2)=-dc_norm(1,i)
2902             uzder(3,3,2)= 0.0d0
2903             endif
2904 C Compute the Y-axis
2905             facy=fac
2906             do k=1,3
2907               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2908             enddo
2909             if (calc_grad) then
2910 C Compute the derivatives of uy
2911             do j=1,3
2912               do k=1,3
2913                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2914      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2915                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2916               enddo
2917               uyder(j,j,1)=uyder(j,j,1)-costh
2918               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2919             enddo
2920             do j=1,2
2921               do k=1,3
2922                 do l=1,3
2923                   uygrad(l,k,j,i)=uyder(l,k,j)
2924                   uzgrad(l,k,j,i)=uzder(l,k,j)
2925                 enddo
2926               enddo
2927             enddo
2928             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2929             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2930             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2931             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2932             endif
2933           else
2934 C Other residues
2935 C Compute the Z-axis
2936             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2937             costh=dcos(pi-theta(i+2))
2938             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2939             do k=1,3
2940               uz(k,i)=fac*uz(k,i)
2941             enddo
2942             if (calc_grad) then
2943 C Compute the derivatives of uz
2944             uzder(1,1,1)= 0.0d0
2945             uzder(2,1,1)=-dc_norm(3,i+1)
2946             uzder(3,1,1)= dc_norm(2,i+1)
2947             uzder(1,2,1)= dc_norm(3,i+1)
2948             uzder(2,2,1)= 0.0d0
2949             uzder(3,2,1)=-dc_norm(1,i+1)
2950             uzder(1,3,1)=-dc_norm(2,i+1)
2951             uzder(2,3,1)= dc_norm(1,i+1)
2952             uzder(3,3,1)= 0.0d0
2953             uzder(1,1,2)= 0.0d0
2954             uzder(2,1,2)= dc_norm(3,i)
2955             uzder(3,1,2)=-dc_norm(2,i)
2956             uzder(1,2,2)=-dc_norm(3,i)
2957             uzder(2,2,2)= 0.0d0
2958             uzder(3,2,2)= dc_norm(1,i)
2959             uzder(1,3,2)= dc_norm(2,i)
2960             uzder(2,3,2)=-dc_norm(1,i)
2961             uzder(3,3,2)= 0.0d0
2962             endif
2963 C Compute the Y-axis
2964             facy=fac
2965             do k=1,3
2966               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2967             enddo
2968             if (calc_grad) then
2969 C Compute the derivatives of uy
2970             do j=1,3
2971               do k=1,3
2972                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2973      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2974                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2975               enddo
2976               uyder(j,j,1)=uyder(j,j,1)-costh
2977               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2978             enddo
2979             do j=1,2
2980               do k=1,3
2981                 do l=1,3
2982                   uygrad(l,k,j,i)=uyder(l,k,j)
2983                   uzgrad(l,k,j,i)=uzder(l,k,j)
2984                 enddo
2985               enddo
2986             enddo
2987             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2988             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2989             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2990             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2991           endif
2992           endif
2993       enddo
2994       if (calc_grad) then
2995       do i=1,nres-1
2996         vbld_inv_temp(1)=vbld_inv(i+1)
2997         if (i.lt.nres-1) then
2998           vbld_inv_temp(2)=vbld_inv(i+2)
2999         else
3000           vbld_inv_temp(2)=vbld_inv(i)
3001         endif
3002         do j=1,2
3003           do k=1,3
3004             do l=1,3
3005               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
3006               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
3007             enddo
3008           enddo
3009         enddo
3010       enddo
3011       endif
3012       return
3013       end
3014 C-----------------------------------------------------------------------------
3015       subroutine vec_and_deriv_test
3016       implicit real*8 (a-h,o-z)
3017       include 'DIMENSIONS'
3018       include 'DIMENSIONS.ZSCOPT'
3019       include 'COMMON.IOUNITS'
3020       include 'COMMON.GEO'
3021       include 'COMMON.VAR'
3022       include 'COMMON.LOCAL'
3023       include 'COMMON.CHAIN'
3024       include 'COMMON.VECTORS'
3025       dimension uyder(3,3,2),uzder(3,3,2)
3026 C Compute the local reference systems. For reference system (i), the
3027 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
3028 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
3029       do i=1,nres-1
3030           if (i.eq.nres-1) then
3031 C Case of the last full residue
3032 C Compute the Z-axis
3033             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
3034             costh=dcos(pi-theta(nres))
3035             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3036 c            write (iout,*) 'fac',fac,
3037 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3038             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3039             do k=1,3
3040               uz(k,i)=fac*uz(k,i)
3041             enddo
3042 C Compute the derivatives of uz
3043             uzder(1,1,1)= 0.0d0
3044             uzder(2,1,1)=-dc_norm(3,i-1)
3045             uzder(3,1,1)= dc_norm(2,i-1)
3046             uzder(1,2,1)= dc_norm(3,i-1)
3047             uzder(2,2,1)= 0.0d0
3048             uzder(3,2,1)=-dc_norm(1,i-1)
3049             uzder(1,3,1)=-dc_norm(2,i-1)
3050             uzder(2,3,1)= dc_norm(1,i-1)
3051             uzder(3,3,1)= 0.0d0
3052             uzder(1,1,2)= 0.0d0
3053             uzder(2,1,2)= dc_norm(3,i)
3054             uzder(3,1,2)=-dc_norm(2,i)
3055             uzder(1,2,2)=-dc_norm(3,i)
3056             uzder(2,2,2)= 0.0d0
3057             uzder(3,2,2)= dc_norm(1,i)
3058             uzder(1,3,2)= dc_norm(2,i)
3059             uzder(2,3,2)=-dc_norm(1,i)
3060             uzder(3,3,2)= 0.0d0
3061 C Compute the Y-axis
3062             do k=1,3
3063               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
3064             enddo
3065             facy=fac
3066             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
3067      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
3068      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
3069             do k=1,3
3070 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3071               uy(k,i)=
3072 c     &        facy*(
3073      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
3074      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
3075 c     &        )
3076             enddo
3077 c            write (iout,*) 'facy',facy,
3078 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3079             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3080             do k=1,3
3081               uy(k,i)=facy*uy(k,i)
3082             enddo
3083 C Compute the derivatives of uy
3084             do j=1,3
3085               do k=1,3
3086                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
3087      &                        -dc_norm(k,i)*dc_norm(j,i-1)
3088                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3089               enddo
3090 c              uyder(j,j,1)=uyder(j,j,1)-costh
3091 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
3092               uyder(j,j,1)=uyder(j,j,1)
3093      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
3094               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
3095      &          +uyder(j,j,2)
3096             enddo
3097             do j=1,2
3098               do k=1,3
3099                 do l=1,3
3100                   uygrad(l,k,j,i)=uyder(l,k,j)
3101                   uzgrad(l,k,j,i)=uzder(l,k,j)
3102                 enddo
3103               enddo
3104             enddo
3105             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3106             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3107             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3108             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3109           else
3110 C Other residues
3111 C Compute the Z-axis
3112             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
3113             costh=dcos(pi-theta(i+2))
3114             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3115             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3116             do k=1,3
3117               uz(k,i)=fac*uz(k,i)
3118             enddo
3119 C Compute the derivatives of uz
3120             uzder(1,1,1)= 0.0d0
3121             uzder(2,1,1)=-dc_norm(3,i+1)
3122             uzder(3,1,1)= dc_norm(2,i+1)
3123             uzder(1,2,1)= dc_norm(3,i+1)
3124             uzder(2,2,1)= 0.0d0
3125             uzder(3,2,1)=-dc_norm(1,i+1)
3126             uzder(1,3,1)=-dc_norm(2,i+1)
3127             uzder(2,3,1)= dc_norm(1,i+1)
3128             uzder(3,3,1)= 0.0d0
3129             uzder(1,1,2)= 0.0d0
3130             uzder(2,1,2)= dc_norm(3,i)
3131             uzder(3,1,2)=-dc_norm(2,i)
3132             uzder(1,2,2)=-dc_norm(3,i)
3133             uzder(2,2,2)= 0.0d0
3134             uzder(3,2,2)= dc_norm(1,i)
3135             uzder(1,3,2)= dc_norm(2,i)
3136             uzder(2,3,2)=-dc_norm(1,i)
3137             uzder(3,3,2)= 0.0d0
3138 C Compute the Y-axis
3139             facy=fac
3140             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
3141      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
3142      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
3143             do k=1,3
3144 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3145               uy(k,i)=
3146 c     &        facy*(
3147      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
3148      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
3149 c     &        )
3150             enddo
3151 c            write (iout,*) 'facy',facy,
3152 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3153             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3154             do k=1,3
3155               uy(k,i)=facy*uy(k,i)
3156             enddo
3157 C Compute the derivatives of uy
3158             do j=1,3
3159               do k=1,3
3160                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
3161      &                        -dc_norm(k,i)*dc_norm(j,i+1)
3162                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3163               enddo
3164 c              uyder(j,j,1)=uyder(j,j,1)-costh
3165 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
3166               uyder(j,j,1)=uyder(j,j,1)
3167      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
3168               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
3169      &          +uyder(j,j,2)
3170             enddo
3171             do j=1,2
3172               do k=1,3
3173                 do l=1,3
3174                   uygrad(l,k,j,i)=uyder(l,k,j)
3175                   uzgrad(l,k,j,i)=uzder(l,k,j)
3176                 enddo
3177               enddo
3178             enddo
3179             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3180             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3181             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3182             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3183           endif
3184       enddo
3185       do i=1,nres-1
3186         do j=1,2
3187           do k=1,3
3188             do l=1,3
3189               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
3190               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
3191             enddo
3192           enddo
3193         enddo
3194       enddo
3195       return
3196       end
3197 C-----------------------------------------------------------------------------
3198       subroutine check_vecgrad
3199       implicit real*8 (a-h,o-z)
3200       include 'DIMENSIONS'
3201       include 'DIMENSIONS.ZSCOPT'
3202       include 'COMMON.IOUNITS'
3203       include 'COMMON.GEO'
3204       include 'COMMON.VAR'
3205       include 'COMMON.LOCAL'
3206       include 'COMMON.CHAIN'
3207       include 'COMMON.VECTORS'
3208       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
3209       dimension uyt(3,maxres),uzt(3,maxres)
3210       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
3211       double precision delta /1.0d-7/
3212       call vec_and_deriv
3213 cd      do i=1,nres
3214 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
3215 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
3216 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
3217 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
3218 cd     &     (dc_norm(if90,i),if90=1,3)
3219 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
3220 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
3221 cd          write(iout,'(a)')
3222 cd      enddo
3223       do i=1,nres
3224         do j=1,2
3225           do k=1,3
3226             do l=1,3
3227               uygradt(l,k,j,i)=uygrad(l,k,j,i)
3228               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
3229             enddo
3230           enddo
3231         enddo
3232       enddo
3233       call vec_and_deriv
3234       do i=1,nres
3235         do j=1,3
3236           uyt(j,i)=uy(j,i)
3237           uzt(j,i)=uz(j,i)
3238         enddo
3239       enddo
3240       do i=1,nres
3241 cd        write (iout,*) 'i=',i
3242         do k=1,3
3243           erij(k)=dc_norm(k,i)
3244         enddo
3245         do j=1,3
3246           do k=1,3
3247             dc_norm(k,i)=erij(k)
3248           enddo
3249           dc_norm(j,i)=dc_norm(j,i)+delta
3250 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
3251 c          do k=1,3
3252 c            dc_norm(k,i)=dc_norm(k,i)/fac
3253 c          enddo
3254 c          write (iout,*) (dc_norm(k,i),k=1,3)
3255 c          write (iout,*) (erij(k),k=1,3)
3256           call vec_and_deriv
3257           do k=1,3
3258             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
3259             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
3260             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
3261             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
3262           enddo
3263 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3264 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
3265 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
3266         enddo
3267         do k=1,3
3268           dc_norm(k,i)=erij(k)
3269         enddo
3270 cd        do k=1,3
3271 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3272 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
3273 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
3274 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3275 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
3276 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
3277 cd          write (iout,'(a)')
3278 cd        enddo
3279       enddo
3280       return
3281       end
3282 C--------------------------------------------------------------------------
3283       subroutine set_matrices
3284       implicit real*8 (a-h,o-z)
3285       include 'DIMENSIONS'
3286       include 'DIMENSIONS.ZSCOPT'
3287       include 'COMMON.IOUNITS'
3288       include 'COMMON.GEO'
3289       include 'COMMON.VAR'
3290       include 'COMMON.LOCAL'
3291       include 'COMMON.CHAIN'
3292       include 'COMMON.DERIV'
3293       include 'COMMON.INTERACT'
3294       include 'COMMON.CONTACTS'
3295       include 'COMMON.TORSION'
3296       include 'COMMON.VECTORS'
3297       include 'COMMON.FFIELD'
3298       double precision auxvec(2),auxmat(2,2)
3299 C
3300 C Compute the virtual-bond-torsional-angle dependent quantities needed
3301 C to calculate the el-loc multibody terms of various order.
3302 C
3303       do i=3,nres+1
3304         if (i .lt. nres+1) then
3305           sin1=dsin(phi(i))
3306           cos1=dcos(phi(i))
3307           sintab(i-2)=sin1
3308           costab(i-2)=cos1
3309           obrot(1,i-2)=cos1
3310           obrot(2,i-2)=sin1
3311           sin2=dsin(2*phi(i))
3312           cos2=dcos(2*phi(i))
3313           sintab2(i-2)=sin2
3314           costab2(i-2)=cos2
3315           obrot2(1,i-2)=cos2
3316           obrot2(2,i-2)=sin2
3317           Ug(1,1,i-2)=-cos1
3318           Ug(1,2,i-2)=-sin1
3319           Ug(2,1,i-2)=-sin1
3320           Ug(2,2,i-2)= cos1
3321           Ug2(1,1,i-2)=-cos2
3322           Ug2(1,2,i-2)=-sin2
3323           Ug2(2,1,i-2)=-sin2
3324           Ug2(2,2,i-2)= cos2
3325         else
3326           costab(i-2)=1.0d0
3327           sintab(i-2)=0.0d0
3328           obrot(1,i-2)=1.0d0
3329           obrot(2,i-2)=0.0d0
3330           obrot2(1,i-2)=0.0d0
3331           obrot2(2,i-2)=0.0d0
3332           Ug(1,1,i-2)=1.0d0
3333           Ug(1,2,i-2)=0.0d0
3334           Ug(2,1,i-2)=0.0d0
3335           Ug(2,2,i-2)=1.0d0
3336           Ug2(1,1,i-2)=0.0d0
3337           Ug2(1,2,i-2)=0.0d0
3338           Ug2(2,1,i-2)=0.0d0
3339           Ug2(2,2,i-2)=0.0d0
3340         endif
3341         if (i .gt. 3 .and. i .lt. nres+1) then
3342           obrot_der(1,i-2)=-sin1
3343           obrot_der(2,i-2)= cos1
3344           Ugder(1,1,i-2)= sin1
3345           Ugder(1,2,i-2)=-cos1
3346           Ugder(2,1,i-2)=-cos1
3347           Ugder(2,2,i-2)=-sin1
3348           dwacos2=cos2+cos2
3349           dwasin2=sin2+sin2
3350           obrot2_der(1,i-2)=-dwasin2
3351           obrot2_der(2,i-2)= dwacos2
3352           Ug2der(1,1,i-2)= dwasin2
3353           Ug2der(1,2,i-2)=-dwacos2
3354           Ug2der(2,1,i-2)=-dwacos2
3355           Ug2der(2,2,i-2)=-dwasin2
3356         else
3357           obrot_der(1,i-2)=0.0d0
3358           obrot_der(2,i-2)=0.0d0
3359           Ugder(1,1,i-2)=0.0d0
3360           Ugder(1,2,i-2)=0.0d0
3361           Ugder(2,1,i-2)=0.0d0
3362           Ugder(2,2,i-2)=0.0d0
3363           obrot2_der(1,i-2)=0.0d0
3364           obrot2_der(2,i-2)=0.0d0
3365           Ug2der(1,1,i-2)=0.0d0
3366           Ug2der(1,2,i-2)=0.0d0
3367           Ug2der(2,1,i-2)=0.0d0
3368           Ug2der(2,2,i-2)=0.0d0
3369         endif
3370         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3371           iti = itortyp(itype(i-2))
3372         else
3373           iti=ntortyp+1
3374         endif
3375         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3376           iti1 = itortyp(itype(i-1))
3377         else
3378           iti1=ntortyp+1
3379         endif
3380 cd        write (iout,*) '*******i',i,' iti1',iti
3381 cd        write (iout,*) 'b1',b1(:,iti)
3382 cd        write (iout,*) 'b2',b2(:,iti)
3383 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3384         if (i .gt. iatel_s+2) then
3385           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
3386           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
3387           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3388           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3389           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3390           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3391           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3392         else
3393           do k=1,2
3394             Ub2(k,i-2)=0.0d0
3395             Ctobr(k,i-2)=0.0d0
3396             Dtobr2(k,i-2)=0.0d0
3397             do l=1,2
3398               EUg(l,k,i-2)=0.0d0
3399               CUg(l,k,i-2)=0.0d0
3400               DUg(l,k,i-2)=0.0d0
3401               DtUg2(l,k,i-2)=0.0d0
3402             enddo
3403           enddo
3404         endif
3405         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
3406         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
3407         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3408         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3409         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3410         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3411         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3412         do k=1,2
3413           muder(k,i-2)=Ub2der(k,i-2)
3414         enddo
3415         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3416           iti1 = itortyp(itype(i-1))
3417         else
3418           iti1=ntortyp+1
3419         endif
3420         do k=1,2
3421           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
3422         enddo
3423 C Vectors and matrices dependent on a single virtual-bond dihedral.
3424         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
3425         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3426         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3427         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3428         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3429         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3430         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3431         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3432         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3433 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
3434 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
3435       enddo
3436 C Matrices dependent on two consecutive virtual-bond dihedrals.
3437 C The order of matrices is from left to right.
3438       do i=2,nres-1
3439         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3440         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3441         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3442         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3443         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3444         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3445         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3446         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3447       enddo
3448 cd      do i=1,nres
3449 cd        iti = itortyp(itype(i))
3450 cd        write (iout,*) i
3451 cd        do j=1,2
3452 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3453 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3454 cd        enddo
3455 cd      enddo
3456       return
3457       end
3458 C--------------------------------------------------------------------------
3459       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3460 C
3461 C This subroutine calculates the average interaction energy and its gradient
3462 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3463 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3464 C The potential depends both on the distance of peptide-group centers and on
3465 C the orientation of the CA-CA virtual bonds.
3466 C
3467       implicit real*8 (a-h,o-z)
3468       include 'DIMENSIONS'
3469       include 'DIMENSIONS.ZSCOPT'
3470       include 'COMMON.CONTROL'
3471       include 'COMMON.IOUNITS'
3472       include 'COMMON.GEO'
3473       include 'COMMON.VAR'
3474       include 'COMMON.LOCAL'
3475       include 'COMMON.CHAIN'
3476       include 'COMMON.DERIV'
3477       include 'COMMON.INTERACT'
3478       include 'COMMON.CONTACTS'
3479       include 'COMMON.TORSION'
3480       include 'COMMON.VECTORS'
3481       include 'COMMON.FFIELD'
3482       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3483      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3484       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3485      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3486       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
3487 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3488       double precision scal_el /0.5d0/
3489 C 12/13/98
3490 C 13-go grudnia roku pamietnego...
3491       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3492      &                   0.0d0,1.0d0,0.0d0,
3493      &                   0.0d0,0.0d0,1.0d0/
3494 cd      write(iout,*) 'In EELEC'
3495 cd      do i=1,nloctyp
3496 cd        write(iout,*) 'Type',i
3497 cd        write(iout,*) 'B1',B1(:,i)
3498 cd        write(iout,*) 'B2',B2(:,i)
3499 cd        write(iout,*) 'CC',CC(:,:,i)
3500 cd        write(iout,*) 'DD',DD(:,:,i)
3501 cd        write(iout,*) 'EE',EE(:,:,i)
3502 cd      enddo
3503 cd      call check_vecgrad
3504 cd      stop
3505       if (icheckgrad.eq.1) then
3506         do i=1,nres-1
3507           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3508           do k=1,3
3509             dc_norm(k,i)=dc(k,i)*fac
3510           enddo
3511 c          write (iout,*) 'i',i,' fac',fac
3512         enddo
3513       endif
3514       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3515      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3516      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3517 cd      if (wel_loc.gt.0.0d0) then
3518         if (icheckgrad.eq.1) then
3519         call vec_and_deriv_test
3520         else
3521         call vec_and_deriv
3522         endif
3523         call set_matrices
3524       endif
3525 cd      do i=1,nres-1
3526 cd        write (iout,*) 'i=',i
3527 cd        do k=1,3
3528 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3529 cd        enddo
3530 cd        do k=1,3
3531 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3532 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3533 cd        enddo
3534 cd      enddo
3535       num_conti_hb=0
3536       ees=0.0D0
3537       evdw1=0.0D0
3538       eel_loc=0.0d0
3539       eello_turn3=0.0d0
3540       eello_turn4=0.0d0
3541       ind=0
3542       do i=1,nres
3543         num_cont_hb(i)=0
3544       enddo
3545 cd      print '(a)','Enter EELEC'
3546 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3547       do i=1,nres
3548         gel_loc_loc(i)=0.0d0
3549         gcorr_loc(i)=0.0d0
3550       enddo
3551       do i=iatel_s,iatel_e
3552         if (itel(i).eq.0) goto 1215
3553         dxi=dc(1,i)
3554         dyi=dc(2,i)
3555         dzi=dc(3,i)
3556         dx_normi=dc_norm(1,i)
3557         dy_normi=dc_norm(2,i)
3558         dz_normi=dc_norm(3,i)
3559         xmedi=c(1,i)+0.5d0*dxi
3560         ymedi=c(2,i)+0.5d0*dyi
3561         zmedi=c(3,i)+0.5d0*dzi
3562         num_conti=0
3563 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3564         do j=ielstart(i),ielend(i)
3565           if (itel(j).eq.0) goto 1216
3566           ind=ind+1
3567           iteli=itel(i)
3568           itelj=itel(j)
3569           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3570           aaa=app(iteli,itelj)
3571           bbb=bpp(iteli,itelj)
3572 C Diagnostics only!!!
3573 c         aaa=0.0D0
3574 c         bbb=0.0D0
3575 c         ael6i=0.0D0
3576 c         ael3i=0.0D0
3577 C End diagnostics
3578           ael6i=ael6(iteli,itelj)
3579           ael3i=ael3(iteli,itelj)
3580           dxj=dc(1,j)
3581           dyj=dc(2,j)
3582           dzj=dc(3,j)
3583           dx_normj=dc_norm(1,j)
3584           dy_normj=dc_norm(2,j)
3585           dz_normj=dc_norm(3,j)
3586           xj=c(1,j)+0.5D0*dxj-xmedi
3587           yj=c(2,j)+0.5D0*dyj-ymedi
3588           zj=c(3,j)+0.5D0*dzj-zmedi
3589           rij=xj*xj+yj*yj+zj*zj
3590           rrmij=1.0D0/rij
3591           rij=dsqrt(rij)
3592           rmij=1.0D0/rij
3593           r3ij=rrmij*rmij
3594           r6ij=r3ij*r3ij
3595           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3596           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3597           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3598           fac=cosa-3.0D0*cosb*cosg
3599           ev1=aaa*r6ij*r6ij
3600 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3601           if (j.eq.i+2) ev1=scal_el*ev1
3602           ev2=bbb*r6ij
3603           fac3=ael6i*r6ij
3604           fac4=ael3i*r3ij
3605           evdwij=ev1+ev2
3606           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3607           el2=fac4*fac
3608           eesij=el1+el2
3609 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
3610 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3611           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3612           ees=ees+eesij
3613           evdw1=evdw1+evdwij
3614 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3615 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3616 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3617 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3618 C
3619 C Calculate contributions to the Cartesian gradient.
3620 C
3621 #ifdef SPLITELE
3622           facvdw=-6*rrmij*(ev1+evdwij)
3623           facel=-3*rrmij*(el1+eesij)
3624           fac1=fac
3625           erij(1)=xj*rmij
3626           erij(2)=yj*rmij
3627           erij(3)=zj*rmij
3628           if (calc_grad) then
3629 *
3630 * Radial derivatives. First process both termini of the fragment (i,j)
3631 *
3632           ggg(1)=facel*xj
3633           ggg(2)=facel*yj
3634           ggg(3)=facel*zj
3635           do k=1,3
3636             ghalf=0.5D0*ggg(k)
3637             gelc(k,i)=gelc(k,i)+ghalf
3638             gelc(k,j)=gelc(k,j)+ghalf
3639           enddo
3640 *
3641 * Loop over residues i+1 thru j-1.
3642 *
3643           do k=i+1,j-1
3644             do l=1,3
3645               gelc(l,k)=gelc(l,k)+ggg(l)
3646             enddo
3647           enddo
3648           ggg(1)=facvdw*xj
3649           ggg(2)=facvdw*yj
3650           ggg(3)=facvdw*zj
3651           do k=1,3
3652             ghalf=0.5D0*ggg(k)
3653             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3654             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3655           enddo
3656 *
3657 * Loop over residues i+1 thru j-1.
3658 *
3659           do k=i+1,j-1
3660             do l=1,3
3661               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3662             enddo
3663           enddo
3664 #else
3665           facvdw=ev1+evdwij
3666           facel=el1+eesij
3667           fac1=fac
3668           fac=-3*rrmij*(facvdw+facvdw+facel)
3669           erij(1)=xj*rmij
3670           erij(2)=yj*rmij
3671           erij(3)=zj*rmij
3672           if (calc_grad) then
3673 *
3674 * Radial derivatives. First process both termini of the fragment (i,j)
3675 *
3676           ggg(1)=fac*xj
3677           ggg(2)=fac*yj
3678           ggg(3)=fac*zj
3679           do k=1,3
3680             ghalf=0.5D0*ggg(k)
3681             gelc(k,i)=gelc(k,i)+ghalf
3682             gelc(k,j)=gelc(k,j)+ghalf
3683           enddo
3684 *
3685 * Loop over residues i+1 thru j-1.
3686 *
3687           do k=i+1,j-1
3688             do l=1,3
3689               gelc(l,k)=gelc(l,k)+ggg(l)
3690             enddo
3691           enddo
3692 #endif
3693 *
3694 * Angular part
3695 *
3696           ecosa=2.0D0*fac3*fac1+fac4
3697           fac4=-3.0D0*fac4
3698           fac3=-6.0D0*fac3
3699           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3700           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3701           do k=1,3
3702             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3703             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3704           enddo
3705 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3706 cd   &          (dcosg(k),k=1,3)
3707           do k=1,3
3708             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3709           enddo
3710           do k=1,3
3711             ghalf=0.5D0*ggg(k)
3712             gelc(k,i)=gelc(k,i)+ghalf
3713      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3714      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3715             gelc(k,j)=gelc(k,j)+ghalf
3716      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3717      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3718           enddo
3719           do k=i+1,j-1
3720             do l=1,3
3721               gelc(l,k)=gelc(l,k)+ggg(l)
3722             enddo
3723           enddo
3724           endif
3725
3726           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3727      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3728      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3729 C
3730 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3731 C   energy of a peptide unit is assumed in the form of a second-order
3732 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3733 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3734 C   are computed for EVERY pair of non-contiguous peptide groups.
3735 C
3736           if (j.lt.nres-1) then
3737             j1=j+1
3738             j2=j-1
3739           else
3740             j1=j-1
3741             j2=j-2
3742           endif
3743           kkk=0
3744           do k=1,2
3745             do l=1,2
3746               kkk=kkk+1
3747               muij(kkk)=mu(k,i)*mu(l,j)
3748             enddo
3749           enddo
3750 cd         write (iout,*) 'EELEC: i',i,' j',j
3751 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3752 cd          write(iout,*) 'muij',muij
3753           ury=scalar(uy(1,i),erij)
3754           urz=scalar(uz(1,i),erij)
3755           vry=scalar(uy(1,j),erij)
3756           vrz=scalar(uz(1,j),erij)
3757           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3758           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3759           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3760           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3761 C For diagnostics only
3762 cd          a22=1.0d0
3763 cd          a23=1.0d0
3764 cd          a32=1.0d0
3765 cd          a33=1.0d0
3766           fac=dsqrt(-ael6i)*r3ij
3767 cd          write (2,*) 'fac=',fac
3768 C For diagnostics only
3769 cd          fac=1.0d0
3770           a22=a22*fac
3771           a23=a23*fac
3772           a32=a32*fac
3773           a33=a33*fac
3774 cd          write (iout,'(4i5,4f10.5)')
3775 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3776 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3777 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
3778 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
3779 cd          write (iout,'(4f10.5)')
3780 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3781 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3782 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3783 cd           write (iout,'(2i3,9f10.5/)') i,j,
3784 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3785           if (calc_grad) then
3786 C Derivatives of the elements of A in virtual-bond vectors
3787           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3788 cd          do k=1,3
3789 cd            do l=1,3
3790 cd              erder(k,l)=0.0d0
3791 cd            enddo
3792 cd          enddo
3793           do k=1,3
3794             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3795             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3796             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3797             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3798             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3799             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3800             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3801             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3802             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3803             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3804             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3805             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3806           enddo
3807 cd          do k=1,3
3808 cd            do l=1,3
3809 cd              uryg(k,l)=0.0d0
3810 cd              urzg(k,l)=0.0d0
3811 cd              vryg(k,l)=0.0d0
3812 cd              vrzg(k,l)=0.0d0
3813 cd            enddo
3814 cd          enddo
3815 C Compute radial contributions to the gradient
3816           facr=-3.0d0*rrmij
3817           a22der=a22*facr
3818           a23der=a23*facr
3819           a32der=a32*facr
3820           a33der=a33*facr
3821 cd          a22der=0.0d0
3822 cd          a23der=0.0d0
3823 cd          a32der=0.0d0
3824 cd          a33der=0.0d0
3825           agg(1,1)=a22der*xj
3826           agg(2,1)=a22der*yj
3827           agg(3,1)=a22der*zj
3828           agg(1,2)=a23der*xj
3829           agg(2,2)=a23der*yj
3830           agg(3,2)=a23der*zj
3831           agg(1,3)=a32der*xj
3832           agg(2,3)=a32der*yj
3833           agg(3,3)=a32der*zj
3834           agg(1,4)=a33der*xj
3835           agg(2,4)=a33der*yj
3836           agg(3,4)=a33der*zj
3837 C Add the contributions coming from er
3838           fac3=-3.0d0*fac
3839           do k=1,3
3840             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3841             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3842             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3843             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3844           enddo
3845           do k=1,3
3846 C Derivatives in DC(i)
3847             ghalf1=0.5d0*agg(k,1)
3848             ghalf2=0.5d0*agg(k,2)
3849             ghalf3=0.5d0*agg(k,3)
3850             ghalf4=0.5d0*agg(k,4)
3851             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3852      &      -3.0d0*uryg(k,2)*vry)+ghalf1
3853             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3854      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
3855             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3856      &      -3.0d0*urzg(k,2)*vry)+ghalf3
3857             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3858      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
3859 C Derivatives in DC(i+1)
3860             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3861      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
3862             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3863      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
3864             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3865      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
3866             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3867      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
3868 C Derivatives in DC(j)
3869             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3870      &      -3.0d0*vryg(k,2)*ury)+ghalf1
3871             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3872      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
3873             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3874      &      -3.0d0*vryg(k,2)*urz)+ghalf3
3875             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3876      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
3877 C Derivatives in DC(j+1) or DC(nres-1)
3878             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3879      &      -3.0d0*vryg(k,3)*ury)
3880             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3881      &      -3.0d0*vrzg(k,3)*ury)
3882             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3883      &      -3.0d0*vryg(k,3)*urz)
3884             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3885      &      -3.0d0*vrzg(k,3)*urz)
3886 cd            aggi(k,1)=ghalf1
3887 cd            aggi(k,2)=ghalf2
3888 cd            aggi(k,3)=ghalf3
3889 cd            aggi(k,4)=ghalf4
3890 C Derivatives in DC(i+1)
3891 cd            aggi1(k,1)=agg(k,1)
3892 cd            aggi1(k,2)=agg(k,2)
3893 cd            aggi1(k,3)=agg(k,3)
3894 cd            aggi1(k,4)=agg(k,4)
3895 C Derivatives in DC(j)
3896 cd            aggj(k,1)=ghalf1
3897 cd            aggj(k,2)=ghalf2
3898 cd            aggj(k,3)=ghalf3
3899 cd            aggj(k,4)=ghalf4
3900 C Derivatives in DC(j+1)
3901 cd            aggj1(k,1)=0.0d0
3902 cd            aggj1(k,2)=0.0d0
3903 cd            aggj1(k,3)=0.0d0
3904 cd            aggj1(k,4)=0.0d0
3905             if (j.eq.nres-1 .and. i.lt.j-2) then
3906               do l=1,4
3907                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
3908 cd                aggj1(k,l)=agg(k,l)
3909               enddo
3910             endif
3911           enddo
3912           endif
3913 c          goto 11111
3914 C Check the loc-el terms by numerical integration
3915           acipa(1,1)=a22
3916           acipa(1,2)=a23
3917           acipa(2,1)=a32
3918           acipa(2,2)=a33
3919           a22=-a22
3920           a23=-a23
3921           do l=1,2
3922             do k=1,3
3923               agg(k,l)=-agg(k,l)
3924               aggi(k,l)=-aggi(k,l)
3925               aggi1(k,l)=-aggi1(k,l)
3926               aggj(k,l)=-aggj(k,l)
3927               aggj1(k,l)=-aggj1(k,l)
3928             enddo
3929           enddo
3930           if (j.lt.nres-1) then
3931             a22=-a22
3932             a32=-a32
3933             do l=1,3,2
3934               do k=1,3
3935                 agg(k,l)=-agg(k,l)
3936                 aggi(k,l)=-aggi(k,l)
3937                 aggi1(k,l)=-aggi1(k,l)
3938                 aggj(k,l)=-aggj(k,l)
3939                 aggj1(k,l)=-aggj1(k,l)
3940               enddo
3941             enddo
3942           else
3943             a22=-a22
3944             a23=-a23
3945             a32=-a32
3946             a33=-a33
3947             do l=1,4
3948               do k=1,3
3949                 agg(k,l)=-agg(k,l)
3950                 aggi(k,l)=-aggi(k,l)
3951                 aggi1(k,l)=-aggi1(k,l)
3952                 aggj(k,l)=-aggj(k,l)
3953                 aggj1(k,l)=-aggj1(k,l)
3954               enddo
3955             enddo
3956           endif
3957           ENDIF ! WCORR
3958 11111     continue
3959           IF (wel_loc.gt.0.0d0) THEN
3960 C Contribution to the local-electrostatic energy coming from the i-j pair
3961           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3962      &     +a33*muij(4)
3963 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3964 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3965           eel_loc=eel_loc+eel_loc_ij
3966 C Partial derivatives in virtual-bond dihedral angles gamma
3967           if (calc_grad) then
3968           if (i.gt.1)
3969      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3970      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3971      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3972           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3973      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3974      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3975 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
3976 cd          write(iout,*) 'agg  ',agg
3977 cd          write(iout,*) 'aggi ',aggi
3978 cd          write(iout,*) 'aggi1',aggi1
3979 cd          write(iout,*) 'aggj ',aggj
3980 cd          write(iout,*) 'aggj1',aggj1
3981
3982 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3983           do l=1,3
3984             ggg(l)=agg(l,1)*muij(1)+
3985      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3986           enddo
3987           do k=i+2,j2
3988             do l=1,3
3989               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3990             enddo
3991           enddo
3992 C Remaining derivatives of eello
3993           do l=1,3
3994             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3995      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3996             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3997      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3998             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3999      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
4000             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
4001      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
4002           enddo
4003           endif
4004           ENDIF
4005           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4006 C Contributions from turns
4007             a_temp(1,1)=a22
4008             a_temp(1,2)=a23
4009             a_temp(2,1)=a32
4010             a_temp(2,2)=a33
4011             call eturn34(i,j,eello_turn3,eello_turn4)
4012           endif
4013 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4014           if (j.gt.i+1 .and. num_conti.le.maxconts) then
4015 C
4016 C Calculate the contact function. The ith column of the array JCONT will
4017 C contain the numbers of atoms that make contacts with the atom I (of numbers
4018 C greater than I). The arrays FACONT and GACONT will contain the values of
4019 C the contact function and its derivative.
4020 c           r0ij=1.02D0*rpp(iteli,itelj)
4021 c           r0ij=1.11D0*rpp(iteli,itelj)
4022             r0ij=2.20D0*rpp(iteli,itelj)
4023 c           r0ij=1.55D0*rpp(iteli,itelj)
4024             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4025             if (fcont.gt.0.0D0) then
4026               num_conti=num_conti+1
4027               if (num_conti.gt.maxconts) then
4028                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4029      &                         ' will skip next contacts for this conf.'
4030               else
4031                 jcont_hb(num_conti,i)=j
4032                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4033      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4034 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4035 C  terms.
4036                 d_cont(num_conti,i)=rij
4037 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4038 C     --- Electrostatic-interaction matrix ---
4039                 a_chuj(1,1,num_conti,i)=a22
4040                 a_chuj(1,2,num_conti,i)=a23
4041                 a_chuj(2,1,num_conti,i)=a32
4042                 a_chuj(2,2,num_conti,i)=a33
4043 C     --- Gradient of rij
4044                 do kkk=1,3
4045                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4046                 enddo
4047 c             if (i.eq.1) then
4048 c                a_chuj(1,1,num_conti,i)=-0.61d0
4049 c                a_chuj(1,2,num_conti,i)= 0.4d0
4050 c                a_chuj(2,1,num_conti,i)= 0.65d0
4051 c                a_chuj(2,2,num_conti,i)= 0.50d0
4052 c             else if (i.eq.2) then
4053 c                a_chuj(1,1,num_conti,i)= 0.0d0
4054 c                a_chuj(1,2,num_conti,i)= 0.0d0
4055 c                a_chuj(2,1,num_conti,i)= 0.0d0
4056 c                a_chuj(2,2,num_conti,i)= 0.0d0
4057 c             endif
4058 C     --- and its gradients
4059 cd                write (iout,*) 'i',i,' j',j
4060 cd                do kkk=1,3
4061 cd                write (iout,*) 'iii 1 kkk',kkk
4062 cd                write (iout,*) agg(kkk,:)
4063 cd                enddo
4064 cd                do kkk=1,3
4065 cd                write (iout,*) 'iii 2 kkk',kkk
4066 cd                write (iout,*) aggi(kkk,:)
4067 cd                enddo
4068 cd                do kkk=1,3
4069 cd                write (iout,*) 'iii 3 kkk',kkk
4070 cd                write (iout,*) aggi1(kkk,:)
4071 cd                enddo
4072 cd                do kkk=1,3
4073 cd                write (iout,*) 'iii 4 kkk',kkk
4074 cd                write (iout,*) aggj(kkk,:)
4075 cd                enddo
4076 cd                do kkk=1,3
4077 cd                write (iout,*) 'iii 5 kkk',kkk
4078 cd                write (iout,*) aggj1(kkk,:)
4079 cd                enddo
4080                 kkll=0
4081                 do k=1,2
4082                   do l=1,2
4083                     kkll=kkll+1
4084                     do m=1,3
4085                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4086                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4087                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4088                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4089                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4090 c                      do mm=1,5
4091 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
4092 c                      enddo
4093                     enddo
4094                   enddo
4095                 enddo
4096                 ENDIF
4097                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4098 C Calculate contact energies
4099                 cosa4=4.0D0*cosa
4100                 wij=cosa-3.0D0*cosb*cosg
4101                 cosbg1=cosb+cosg
4102                 cosbg2=cosb-cosg
4103 c               fac3=dsqrt(-ael6i)/r0ij**3
4104                 fac3=dsqrt(-ael6i)*r3ij
4105                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4106                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4107 c               ees0mij=0.0D0
4108                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4109                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4110 C Diagnostics. Comment out or remove after debugging!
4111 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4112 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4113 c               ees0m(num_conti,i)=0.0D0
4114 C End diagnostics.
4115 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4116 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4117                 facont_hb(num_conti,i)=fcont
4118                 if (calc_grad) then
4119 C Angular derivatives of the contact function
4120                 ees0pij1=fac3/ees0pij
4121                 ees0mij1=fac3/ees0mij
4122                 fac3p=-3.0D0*fac3*rrmij
4123                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4124                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4125 c               ees0mij1=0.0D0
4126                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4127                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4128                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4129                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4130                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4131                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4132                 ecosap=ecosa1+ecosa2
4133                 ecosbp=ecosb1+ecosb2
4134                 ecosgp=ecosg1+ecosg2
4135                 ecosam=ecosa1-ecosa2
4136                 ecosbm=ecosb1-ecosb2
4137                 ecosgm=ecosg1-ecosg2
4138 C Diagnostics
4139 c               ecosap=ecosa1
4140 c               ecosbp=ecosb1
4141 c               ecosgp=ecosg1
4142 c               ecosam=0.0D0
4143 c               ecosbm=0.0D0
4144 c               ecosgm=0.0D0
4145 C End diagnostics
4146                 fprimcont=fprimcont/rij
4147 cd              facont_hb(num_conti,i)=1.0D0
4148 C Following line is for diagnostics.
4149 cd              fprimcont=0.0D0
4150                 do k=1,3
4151                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4152                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4153                 enddo
4154                 do k=1,3
4155                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4156                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4157                 enddo
4158                 gggp(1)=gggp(1)+ees0pijp*xj
4159                 gggp(2)=gggp(2)+ees0pijp*yj
4160                 gggp(3)=gggp(3)+ees0pijp*zj
4161                 gggm(1)=gggm(1)+ees0mijp*xj
4162                 gggm(2)=gggm(2)+ees0mijp*yj
4163                 gggm(3)=gggm(3)+ees0mijp*zj
4164 C Derivatives due to the contact function
4165                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4166                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4167                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4168                 do k=1,3
4169                   ghalfp=0.5D0*gggp(k)
4170                   ghalfm=0.5D0*gggm(k)
4171                   gacontp_hb1(k,num_conti,i)=ghalfp
4172      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4173      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4174                   gacontp_hb2(k,num_conti,i)=ghalfp
4175      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4176      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4177                   gacontp_hb3(k,num_conti,i)=gggp(k)
4178                   gacontm_hb1(k,num_conti,i)=ghalfm
4179      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4180      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4181                   gacontm_hb2(k,num_conti,i)=ghalfm
4182      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4183      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4184                   gacontm_hb3(k,num_conti,i)=gggm(k)
4185                 enddo
4186                 endif
4187 C Diagnostics. Comment out or remove after debugging!
4188 cdiag           do k=1,3
4189 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4190 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4191 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4192 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4193 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4194 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4195 cdiag           enddo
4196               ENDIF ! wcorr
4197               endif  ! num_conti.le.maxconts
4198             endif  ! fcont.gt.0
4199           endif    ! j.gt.i+1
4200  1216     continue
4201         enddo ! j
4202         num_cont_hb(i)=num_conti
4203  1215   continue
4204       enddo   ! i
4205 cd      do i=1,nres
4206 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
4207 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
4208 cd      enddo
4209 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
4210 ccc      eel_loc=eel_loc+eello_turn3
4211       return
4212       end
4213 C-----------------------------------------------------------------------------
4214       subroutine eturn34(i,j,eello_turn3,eello_turn4)
4215 C Third- and fourth-order contributions from turns
4216       implicit real*8 (a-h,o-z)
4217       include 'DIMENSIONS'
4218       include 'DIMENSIONS.ZSCOPT'
4219       include 'COMMON.IOUNITS'
4220       include 'COMMON.GEO'
4221       include 'COMMON.VAR'
4222       include 'COMMON.LOCAL'
4223       include 'COMMON.CHAIN'
4224       include 'COMMON.DERIV'
4225       include 'COMMON.INTERACT'
4226       include 'COMMON.CONTACTS'
4227       include 'COMMON.TORSION'
4228       include 'COMMON.VECTORS'
4229       include 'COMMON.FFIELD'
4230       dimension ggg(3)
4231       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4232      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4233      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
4234       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4235      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
4236       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
4237       if (j.eq.i+2) then
4238 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4239 C
4240 C               Third-order contributions
4241 C
4242 C                 (i+2)o----(i+3)
4243 C                      | |
4244 C                      | |
4245 C                 (i+1)o----i
4246 C
4247 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4248 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4249         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4250         call transpose2(auxmat(1,1),auxmat1(1,1))
4251         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4252         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4253 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4254 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4255 cd     &    ' eello_turn3_num',4*eello_turn3_num
4256         if (calc_grad) then
4257 C Derivatives in gamma(i)
4258         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4259         call transpose2(auxmat2(1,1),pizda(1,1))
4260         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
4261         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4262 C Derivatives in gamma(i+1)
4263         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4264         call transpose2(auxmat2(1,1),pizda(1,1))
4265         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
4266         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4267      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4268 C Cartesian derivatives
4269         do l=1,3
4270           a_temp(1,1)=aggi(l,1)
4271           a_temp(1,2)=aggi(l,2)
4272           a_temp(2,1)=aggi(l,3)
4273           a_temp(2,2)=aggi(l,4)
4274           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4275           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4276      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4277           a_temp(1,1)=aggi1(l,1)
4278           a_temp(1,2)=aggi1(l,2)
4279           a_temp(2,1)=aggi1(l,3)
4280           a_temp(2,2)=aggi1(l,4)
4281           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4282           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4283      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4284           a_temp(1,1)=aggj(l,1)
4285           a_temp(1,2)=aggj(l,2)
4286           a_temp(2,1)=aggj(l,3)
4287           a_temp(2,2)=aggj(l,4)
4288           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4289           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4290      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4291           a_temp(1,1)=aggj1(l,1)
4292           a_temp(1,2)=aggj1(l,2)
4293           a_temp(2,1)=aggj1(l,3)
4294           a_temp(2,2)=aggj1(l,4)
4295           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4296           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4297      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4298         enddo
4299         endif
4300       else if (j.eq.i+3) then
4301 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4302 C
4303 C               Fourth-order contributions
4304 C
4305 C                 (i+3)o----(i+4)
4306 C                     /  |
4307 C               (i+2)o   |
4308 C                     \  |
4309 C                 (i+1)o----i
4310 C
4311 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4312 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4313         iti1=itortyp(itype(i+1))
4314         iti2=itortyp(itype(i+2))
4315         iti3=itortyp(itype(i+3))
4316         call transpose2(EUg(1,1,i+1),e1t(1,1))
4317         call transpose2(Eug(1,1,i+2),e2t(1,1))
4318         call transpose2(Eug(1,1,i+3),e3t(1,1))
4319         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4320         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4321         s1=scalar2(b1(1,iti2),auxvec(1))
4322         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4323         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4324         s2=scalar2(b1(1,iti1),auxvec(1))
4325         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4326         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4327         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4328         eello_turn4=eello_turn4-(s1+s2+s3)
4329 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4330 cd     &    ' eello_turn4_num',8*eello_turn4_num
4331 C Derivatives in gamma(i)
4332         if (calc_grad) then
4333         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4334         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4335         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4336         s1=scalar2(b1(1,iti2),auxvec(1))
4337         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4338         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4339         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4340 C Derivatives in gamma(i+1)
4341         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4342         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4343         s2=scalar2(b1(1,iti1),auxvec(1))
4344         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4345         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4346         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4347         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4348 C Derivatives in gamma(i+2)
4349         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4350         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4351         s1=scalar2(b1(1,iti2),auxvec(1))
4352         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4353         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4354         s2=scalar2(b1(1,iti1),auxvec(1))
4355         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
4356         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4357         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4358         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4359 C Cartesian derivatives
4360 C Derivatives of this turn contributions in DC(i+2)
4361         if (j.lt.nres-1) then
4362           do l=1,3
4363             a_temp(1,1)=agg(l,1)
4364             a_temp(1,2)=agg(l,2)
4365             a_temp(2,1)=agg(l,3)
4366             a_temp(2,2)=agg(l,4)
4367             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4368             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4369             s1=scalar2(b1(1,iti2),auxvec(1))
4370             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4371             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4372             s2=scalar2(b1(1,iti1),auxvec(1))
4373             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4374             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4375             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4376             ggg(l)=-(s1+s2+s3)
4377             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4378           enddo
4379         endif
4380 C Remaining derivatives of this turn contribution
4381         do l=1,3
4382           a_temp(1,1)=aggi(l,1)
4383           a_temp(1,2)=aggi(l,2)
4384           a_temp(2,1)=aggi(l,3)
4385           a_temp(2,2)=aggi(l,4)
4386           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4387           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4388           s1=scalar2(b1(1,iti2),auxvec(1))
4389           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4390           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4391           s2=scalar2(b1(1,iti1),auxvec(1))
4392           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4393           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4394           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4395           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4396           a_temp(1,1)=aggi1(l,1)
4397           a_temp(1,2)=aggi1(l,2)
4398           a_temp(2,1)=aggi1(l,3)
4399           a_temp(2,2)=aggi1(l,4)
4400           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4401           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4402           s1=scalar2(b1(1,iti2),auxvec(1))
4403           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4404           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4405           s2=scalar2(b1(1,iti1),auxvec(1))
4406           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4407           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4408           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4409           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4410           a_temp(1,1)=aggj(l,1)
4411           a_temp(1,2)=aggj(l,2)
4412           a_temp(2,1)=aggj(l,3)
4413           a_temp(2,2)=aggj(l,4)
4414           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4415           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4416           s1=scalar2(b1(1,iti2),auxvec(1))
4417           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4418           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4419           s2=scalar2(b1(1,iti1),auxvec(1))
4420           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4421           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4422           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4423           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4424           a_temp(1,1)=aggj1(l,1)
4425           a_temp(1,2)=aggj1(l,2)
4426           a_temp(2,1)=aggj1(l,3)
4427           a_temp(2,2)=aggj1(l,4)
4428           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4429           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4430           s1=scalar2(b1(1,iti2),auxvec(1))
4431           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4432           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4433           s2=scalar2(b1(1,iti1),auxvec(1))
4434           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4435           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4436           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4437           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4438         enddo
4439         endif
4440       endif
4441       return
4442       end
4443 C-----------------------------------------------------------------------------
4444       subroutine vecpr(u,v,w)
4445       implicit real*8(a-h,o-z)
4446       dimension u(3),v(3),w(3)
4447       w(1)=u(2)*v(3)-u(3)*v(2)
4448       w(2)=-u(1)*v(3)+u(3)*v(1)
4449       w(3)=u(1)*v(2)-u(2)*v(1)
4450       return
4451       end
4452 C-----------------------------------------------------------------------------
4453       subroutine unormderiv(u,ugrad,unorm,ungrad)
4454 C This subroutine computes the derivatives of a normalized vector u, given
4455 C the derivatives computed without normalization conditions, ugrad. Returns
4456 C ungrad.
4457       implicit none
4458       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4459       double precision vec(3)
4460       double precision scalar
4461       integer i,j
4462 c      write (2,*) 'ugrad',ugrad
4463 c      write (2,*) 'u',u
4464       do i=1,3
4465         vec(i)=scalar(ugrad(1,i),u(1))
4466       enddo
4467 c      write (2,*) 'vec',vec
4468       do i=1,3
4469         do j=1,3
4470           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4471         enddo
4472       enddo
4473 c      write (2,*) 'ungrad',ungrad
4474       return
4475       end
4476 C-----------------------------------------------------------------------------
4477       subroutine escp(evdw2,evdw2_14)
4478 C
4479 C This subroutine calculates the excluded-volume interaction energy between
4480 C peptide-group centers and side chains and its gradient in virtual-bond and
4481 C side-chain vectors.
4482 C
4483       implicit real*8 (a-h,o-z)
4484       include 'DIMENSIONS'
4485       include 'DIMENSIONS.ZSCOPT'
4486       include 'COMMON.GEO'
4487       include 'COMMON.VAR'
4488       include 'COMMON.LOCAL'
4489       include 'COMMON.CHAIN'
4490       include 'COMMON.DERIV'
4491       include 'COMMON.INTERACT'
4492       include 'COMMON.FFIELD'
4493       include 'COMMON.IOUNITS'
4494       dimension ggg(3)
4495       evdw2=0.0D0
4496       evdw2_14=0.0d0
4497 cd    print '(a)','Enter ESCP'
4498 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
4499 c     &  ' scal14',scal14
4500       do i=iatscp_s,iatscp_e
4501         iteli=itel(i)
4502 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
4503 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
4504         if (iteli.eq.0) goto 1225
4505         xi=0.5D0*(c(1,i)+c(1,i+1))
4506         yi=0.5D0*(c(2,i)+c(2,i+1))
4507         zi=0.5D0*(c(3,i)+c(3,i+1))
4508
4509         do iint=1,nscp_gr(i)
4510
4511         do j=iscpstart(i,iint),iscpend(i,iint)
4512           itypj=itype(j)
4513 C Uncomment following three lines for SC-p interactions
4514 c         xj=c(1,nres+j)-xi
4515 c         yj=c(2,nres+j)-yi
4516 c         zj=c(3,nres+j)-zi
4517 C Uncomment following three lines for Ca-p interactions
4518           xj=c(1,j)-xi
4519           yj=c(2,j)-yi
4520           zj=c(3,j)-zi
4521           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4522           fac=rrij**expon2
4523           e1=fac*fac*aad(itypj,iteli)
4524           e2=fac*bad(itypj,iteli)
4525           if (iabs(j-i) .le. 2) then
4526             e1=scal14*e1
4527             e2=scal14*e2
4528             evdw2_14=evdw2_14+e1+e2
4529           endif
4530           evdwij=e1+e2
4531 c          write (iout,*) i,j,evdwij
4532           evdw2=evdw2+evdwij
4533           if (calc_grad) then
4534 C
4535 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4536 C
4537           fac=-(evdwij+e1)*rrij
4538           ggg(1)=xj*fac
4539           ggg(2)=yj*fac
4540           ggg(3)=zj*fac
4541           if (j.lt.i) then
4542 cd          write (iout,*) 'j<i'
4543 C Uncomment following three lines for SC-p interactions
4544 c           do k=1,3
4545 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4546 c           enddo
4547           else
4548 cd          write (iout,*) 'j>i'
4549             do k=1,3
4550               ggg(k)=-ggg(k)
4551 C Uncomment following line for SC-p interactions
4552 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4553             enddo
4554           endif
4555           do k=1,3
4556             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4557           enddo
4558           kstart=min0(i+1,j)
4559           kend=max0(i-1,j-1)
4560 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4561 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4562           do k=kstart,kend
4563             do l=1,3
4564               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4565             enddo
4566           enddo
4567           endif
4568         enddo
4569         enddo ! iint
4570  1225   continue
4571       enddo ! i
4572       do i=1,nct
4573         do j=1,3
4574           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4575           gradx_scp(j,i)=expon*gradx_scp(j,i)
4576         enddo
4577       enddo
4578 C******************************************************************************
4579 C
4580 C                              N O T E !!!
4581 C
4582 C To save time the factor EXPON has been extracted from ALL components
4583 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4584 C use!
4585 C
4586 C******************************************************************************
4587       return
4588       end
4589 C--------------------------------------------------------------------------
4590       subroutine edis(ehpb)
4591 C
4592 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4593 C
4594       implicit real*8 (a-h,o-z)
4595       include 'DIMENSIONS'
4596       include 'COMMON.SBRIDGE'
4597       include 'COMMON.CHAIN'
4598       include 'COMMON.DERIV'
4599       include 'COMMON.VAR'
4600       include 'COMMON.INTERACT'
4601       include 'COMMON.IOUNITS'
4602       dimension ggg(3)
4603       ehpb=0.0D0
4604 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4605 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4606       if (link_end.eq.0) return
4607       do i=link_start,link_end
4608 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4609 C CA-CA distance used in regularization of structure.
4610         ii=ihpb(i)
4611         jj=jhpb(i)
4612 C iii and jjj point to the residues for which the distance is assigned.
4613         if (ii.gt.nres) then
4614           iii=ii-nres
4615           jjj=jj-nres
4616         else
4617           iii=ii
4618           jjj=jj
4619         endif
4620 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4621 c     &    dhpb(i),dhpb1(i),forcon(i)
4622 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4623 C    distance and angle dependent SS bond potential.
4624         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4625           call ssbond_ene(iii,jjj,eij)
4626           ehpb=ehpb+2*eij
4627 cd          write (iout,*) "eij",eij
4628         else if (ii.gt.nres .and. jj.gt.nres) then
4629 c Restraints from contact prediction
4630           dd=dist(ii,jj)
4631           if (dhpb1(i).gt.0.0d0) then
4632             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4633             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4634 c            write (iout,*) "beta nmr",
4635 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4636           else
4637             dd=dist(ii,jj)
4638             rdis=dd-dhpb(i)
4639 C Get the force constant corresponding to this distance.
4640             waga=forcon(i)
4641 C Calculate the contribution to energy.
4642             ehpb=ehpb+waga*rdis*rdis
4643 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4644 C
4645 C Evaluate gradient.
4646 C
4647             fac=waga*rdis/dd
4648           endif
4649           do j=1,3
4650             ggg(j)=fac*(c(j,jj)-c(j,ii))
4651           enddo
4652           do j=1,3
4653             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4654             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4655           enddo
4656           do k=1,3
4657             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4658             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4659           enddo
4660         else
4661 C Calculate the distance between the two points and its difference from the
4662 C target distance.
4663           dd=dist(ii,jj)
4664           if (dhpb1(i).gt.0.0d0) then
4665             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4666             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4667 c            write (iout,*) "alph nmr",
4668 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4669           else
4670             rdis=dd-dhpb(i)
4671 C Get the force constant corresponding to this distance.
4672             waga=forcon(i)
4673 C Calculate the contribution to energy.
4674             ehpb=ehpb+waga*rdis*rdis
4675 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4676 C
4677 C Evaluate gradient.
4678 C
4679             fac=waga*rdis/dd
4680           endif
4681 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4682 cd   &   ' waga=',waga,' fac=',fac
4683             do j=1,3
4684               ggg(j)=fac*(c(j,jj)-c(j,ii))
4685             enddo
4686 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4687 C If this is a SC-SC distance, we need to calculate the contributions to the
4688 C Cartesian gradient in the SC vectors (ghpbx).
4689           if (iii.lt.ii) then
4690           do j=1,3
4691             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4692             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4693           enddo
4694           endif
4695           do k=1,3
4696             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4697             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4698           enddo
4699         endif
4700       enddo
4701       ehpb=0.5D0*ehpb
4702       return
4703       end
4704 C--------------------------------------------------------------------------
4705       subroutine ssbond_ene(i,j,eij)
4706 C
4707 C Calculate the distance and angle dependent SS-bond potential energy
4708 C using a free-energy function derived based on RHF/6-31G** ab initio
4709 C calculations of diethyl disulfide.
4710 C
4711 C A. Liwo and U. Kozlowska, 11/24/03
4712 C
4713       implicit real*8 (a-h,o-z)
4714       include 'DIMENSIONS'
4715       include 'DIMENSIONS.ZSCOPT'
4716       include 'COMMON.SBRIDGE'
4717       include 'COMMON.CHAIN'
4718       include 'COMMON.DERIV'
4719       include 'COMMON.LOCAL'
4720       include 'COMMON.INTERACT'
4721       include 'COMMON.VAR'
4722       include 'COMMON.IOUNITS'
4723       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4724       itypi=itype(i)
4725       xi=c(1,nres+i)
4726       yi=c(2,nres+i)
4727       zi=c(3,nres+i)
4728       dxi=dc_norm(1,nres+i)
4729       dyi=dc_norm(2,nres+i)
4730       dzi=dc_norm(3,nres+i)
4731       dsci_inv=dsc_inv(itypi)
4732       itypj=itype(j)
4733       dscj_inv=dsc_inv(itypj)
4734       xj=c(1,nres+j)-xi
4735       yj=c(2,nres+j)-yi
4736       zj=c(3,nres+j)-zi
4737       dxj=dc_norm(1,nres+j)
4738       dyj=dc_norm(2,nres+j)
4739       dzj=dc_norm(3,nres+j)
4740       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4741       rij=dsqrt(rrij)
4742       erij(1)=xj*rij
4743       erij(2)=yj*rij
4744       erij(3)=zj*rij
4745       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4746       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4747       om12=dxi*dxj+dyi*dyj+dzi*dzj
4748       do k=1,3
4749         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4750         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4751       enddo
4752       rij=1.0d0/rij
4753       deltad=rij-d0cm
4754       deltat1=1.0d0-om1
4755       deltat2=1.0d0+om2
4756       deltat12=om2-om1+2.0d0
4757       cosphi=om12-om1*om2
4758       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4759      &  +akct*deltad*deltat12
4760      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4761 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4762 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4763 c     &  " deltat12",deltat12," eij",eij
4764       ed=2*akcm*deltad+akct*deltat12
4765       pom1=akct*deltad
4766       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4767       eom1=-2*akth*deltat1-pom1-om2*pom2
4768       eom2= 2*akth*deltat2+pom1-om1*pom2
4769       eom12=pom2
4770       do k=1,3
4771         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4772       enddo
4773       do k=1,3
4774         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4775      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4776         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4777      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4778       enddo
4779 C
4780 C Calculate the components of the gradient in DC and X
4781 C
4782       do k=i,j-1
4783         do l=1,3
4784           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4785         enddo
4786       enddo
4787       return
4788       end
4789 C--------------------------------------------------------------------------
4790       subroutine ebond(estr)
4791 c
4792 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4793 c
4794       implicit real*8 (a-h,o-z)
4795       include 'DIMENSIONS'
4796       include 'DIMENSIONS.ZSCOPT'
4797       include 'COMMON.LOCAL'
4798       include 'COMMON.GEO'
4799       include 'COMMON.INTERACT'
4800       include 'COMMON.DERIV'
4801       include 'COMMON.VAR'
4802       include 'COMMON.CHAIN'
4803       include 'COMMON.IOUNITS'
4804       include 'COMMON.NAMES'
4805       include 'COMMON.FFIELD'
4806       include 'COMMON.CONTROL'
4807       double precision u(3),ud(3)
4808       estr=0.0d0
4809       do i=nnt+1,nct
4810         diff = vbld(i)-vbldp0
4811 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4812         estr=estr+diff*diff
4813         do j=1,3
4814           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4815         enddo
4816       enddo
4817       estr=0.5d0*AKP*estr
4818 c
4819 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4820 c
4821       do i=nnt,nct
4822         iti=itype(i)
4823         if (iti.ne.10) then
4824           nbi=nbondterm(iti)
4825           if (nbi.eq.1) then
4826             diff=vbld(i+nres)-vbldsc0(1,iti)
4827 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4828 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4829             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4830             do j=1,3
4831               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4832             enddo
4833           else
4834             do j=1,nbi
4835               diff=vbld(i+nres)-vbldsc0(j,iti)
4836               ud(j)=aksc(j,iti)*diff
4837               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4838             enddo
4839             uprod=u(1)
4840             do j=2,nbi
4841               uprod=uprod*u(j)
4842             enddo
4843             usum=0.0d0
4844             usumsqder=0.0d0
4845             do j=1,nbi
4846               uprod1=1.0d0
4847               uprod2=1.0d0
4848               do k=1,nbi
4849                 if (k.ne.j) then
4850                   uprod1=uprod1*u(k)
4851                   uprod2=uprod2*u(k)*u(k)
4852                 endif
4853               enddo
4854               usum=usum+uprod1
4855               usumsqder=usumsqder+ud(j)*uprod2
4856             enddo
4857 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4858 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4859             estr=estr+uprod/usum
4860             do j=1,3
4861              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4862             enddo
4863           endif
4864         endif
4865       enddo
4866       return
4867       end
4868 #ifdef CRYST_THETA
4869 C--------------------------------------------------------------------------
4870       subroutine ebend(etheta)
4871 C
4872 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4873 C angles gamma and its derivatives in consecutive thetas and gammas.
4874 C
4875       implicit real*8 (a-h,o-z)
4876       include 'DIMENSIONS'
4877       include 'DIMENSIONS.ZSCOPT'
4878       include 'COMMON.LOCAL'
4879       include 'COMMON.GEO'
4880       include 'COMMON.INTERACT'
4881       include 'COMMON.DERIV'
4882       include 'COMMON.VAR'
4883       include 'COMMON.CHAIN'
4884       include 'COMMON.IOUNITS'
4885       include 'COMMON.NAMES'
4886       include 'COMMON.FFIELD'
4887       common /calcthet/ term1,term2,termm,diffak,ratak,
4888      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4889      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4890       double precision y(2),z(2)
4891       delta=0.02d0*pi
4892       time11=dexp(-2*time)
4893       time12=1.0d0
4894       etheta=0.0D0
4895 c      write (iout,*) "nres",nres
4896 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4897 c      write (iout,*) ithet_start,ithet_end
4898       do i=ithet_start,ithet_end
4899 C Zero the energy function and its derivative at 0 or pi.
4900         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4901         it=itype(i-1)
4902 c        if (i.gt.ithet_start .and.
4903 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
4904 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
4905 c          phii=phi(i)
4906 c          y(1)=dcos(phii)
4907 c          y(2)=dsin(phii)
4908 c        else
4909 c          y(1)=0.0D0
4910 c          y(2)=0.0D0
4911 c        endif
4912 c        if (i.lt.nres .and. itel(i).ne.0) then
4913 c          phii1=phi(i+1)
4914 c          z(1)=dcos(phii1)
4915 c          z(2)=dsin(phii1)
4916 c        else
4917 c          z(1)=0.0D0
4918 c          z(2)=0.0D0
4919 c        endif
4920         if (i.gt.3) then
4921 #ifdef OSF
4922           phii=phi(i)
4923           icrc=0
4924           call proc_proc(phii,icrc)
4925           if (icrc.eq.1) phii=150.0
4926 #else
4927           phii=phi(i)
4928 #endif
4929           y(1)=dcos(phii)
4930           y(2)=dsin(phii)
4931         else
4932           y(1)=0.0D0
4933           y(2)=0.0D0
4934         endif
4935         if (i.lt.nres) then
4936 #ifdef OSF
4937           phii1=phi(i+1)
4938           icrc=0
4939           call proc_proc(phii1,icrc)
4940           if (icrc.eq.1) phii1=150.0
4941           phii1=pinorm(phii1)
4942           z(1)=cos(phii1)
4943 #else
4944           phii1=phi(i+1)
4945           z(1)=dcos(phii1)
4946 #endif
4947           z(2)=dsin(phii1)
4948         else
4949           z(1)=0.0D0
4950           z(2)=0.0D0
4951         endif
4952 C Calculate the "mean" value of theta from the part of the distribution
4953 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4954 C In following comments this theta will be referred to as t_c.
4955         thet_pred_mean=0.0d0
4956         do k=1,2
4957           athetk=athet(k,it)
4958           bthetk=bthet(k,it)
4959           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4960         enddo
4961 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4962         dthett=thet_pred_mean*ssd
4963         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4964 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4965 C Derivatives of the "mean" values in gamma1 and gamma2.
4966         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4967         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4968         if (theta(i).gt.pi-delta) then
4969           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4970      &         E_tc0)
4971           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4972           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4973           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4974      &        E_theta)
4975           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4976      &        E_tc)
4977         else if (theta(i).lt.delta) then
4978           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4979           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4980           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4981      &        E_theta)
4982           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4983           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4984      &        E_tc)
4985         else
4986           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4987      &        E_theta,E_tc)
4988         endif
4989         etheta=etheta+ethetai
4990 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4991 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4992         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4993         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4994         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4995  1215   continue
4996       enddo
4997 C Ufff.... We've done all this!!!
4998       return
4999       end
5000 C---------------------------------------------------------------------------
5001       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5002      &     E_tc)
5003       implicit real*8 (a-h,o-z)
5004       include 'DIMENSIONS'
5005       include 'COMMON.LOCAL'
5006       include 'COMMON.IOUNITS'
5007       common /calcthet/ term1,term2,termm,diffak,ratak,
5008      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5009      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5010 C Calculate the contributions to both Gaussian lobes.
5011 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5012 C The "polynomial part" of the "standard deviation" of this part of
5013 C the distribution.
5014         sig=polthet(3,it)
5015         do j=2,0,-1
5016           sig=sig*thet_pred_mean+polthet(j,it)
5017         enddo
5018 C Derivative of the "interior part" of the "standard deviation of the"
5019 C gamma-dependent Gaussian lobe in t_c.
5020         sigtc=3*polthet(3,it)
5021         do j=2,1,-1
5022           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5023         enddo
5024         sigtc=sig*sigtc
5025 C Set the parameters of both Gaussian lobes of the distribution.
5026 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5027         fac=sig*sig+sigc0(it)
5028         sigcsq=fac+fac
5029         sigc=1.0D0/sigcsq
5030 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5031         sigsqtc=-4.0D0*sigcsq*sigtc
5032 c       print *,i,sig,sigtc,sigsqtc
5033 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5034         sigtc=-sigtc/(fac*fac)
5035 C Following variable is sigma(t_c)**(-2)
5036         sigcsq=sigcsq*sigcsq
5037         sig0i=sig0(it)
5038         sig0inv=1.0D0/sig0i**2
5039         delthec=thetai-thet_pred_mean
5040         delthe0=thetai-theta0i
5041         term1=-0.5D0*sigcsq*delthec*delthec
5042         term2=-0.5D0*sig0inv*delthe0*delthe0
5043 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5044 C NaNs in taking the logarithm. We extract the largest exponent which is added
5045 C to the energy (this being the log of the distribution) at the end of energy
5046 C term evaluation for this virtual-bond angle.
5047         if (term1.gt.term2) then
5048           termm=term1
5049           term2=dexp(term2-termm)
5050           term1=1.0d0
5051         else
5052           termm=term2
5053           term1=dexp(term1-termm)
5054           term2=1.0d0
5055         endif
5056 C The ratio between the gamma-independent and gamma-dependent lobes of
5057 C the distribution is a Gaussian function of thet_pred_mean too.
5058         diffak=gthet(2,it)-thet_pred_mean
5059         ratak=diffak/gthet(3,it)**2
5060         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5061 C Let's differentiate it in thet_pred_mean NOW.
5062         aktc=ak*ratak
5063 C Now put together the distribution terms to make complete distribution.
5064         termexp=term1+ak*term2
5065         termpre=sigc+ak*sig0i
5066 C Contribution of the bending energy from this theta is just the -log of
5067 C the sum of the contributions from the two lobes and the pre-exponential
5068 C factor. Simple enough, isn't it?
5069         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5070 C NOW the derivatives!!!
5071 C 6/6/97 Take into account the deformation.
5072         E_theta=(delthec*sigcsq*term1
5073      &       +ak*delthe0*sig0inv*term2)/termexp
5074         E_tc=((sigtc+aktc*sig0i)/termpre
5075      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5076      &       aktc*term2)/termexp)
5077       return
5078       end
5079 c-----------------------------------------------------------------------------
5080       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5081       implicit real*8 (a-h,o-z)
5082       include 'DIMENSIONS'
5083       include 'COMMON.LOCAL'
5084       include 'COMMON.IOUNITS'
5085       common /calcthet/ term1,term2,termm,diffak,ratak,
5086      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5087      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5088       delthec=thetai-thet_pred_mean
5089       delthe0=thetai-theta0i
5090 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5091       t3 = thetai-thet_pred_mean
5092       t6 = t3**2
5093       t9 = term1
5094       t12 = t3*sigcsq
5095       t14 = t12+t6*sigsqtc
5096       t16 = 1.0d0
5097       t21 = thetai-theta0i
5098       t23 = t21**2
5099       t26 = term2
5100       t27 = t21*t26
5101       t32 = termexp
5102       t40 = t32**2
5103       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5104      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5105      & *(-t12*t9-ak*sig0inv*t27)
5106       return
5107       end
5108 #else
5109 C--------------------------------------------------------------------------
5110       subroutine ebend(etheta)
5111 C
5112 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5113 C angles gamma and its derivatives in consecutive thetas and gammas.
5114 C ab initio-derived potentials from
5115 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5116 C
5117       implicit real*8 (a-h,o-z)
5118       include 'DIMENSIONS'
5119       include 'DIMENSIONS.ZSCOPT'
5120       include 'COMMON.LOCAL'
5121       include 'COMMON.GEO'
5122       include 'COMMON.INTERACT'
5123       include 'COMMON.DERIV'
5124       include 'COMMON.VAR'
5125       include 'COMMON.CHAIN'
5126       include 'COMMON.IOUNITS'
5127       include 'COMMON.NAMES'
5128       include 'COMMON.FFIELD'
5129       include 'COMMON.CONTROL'
5130       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5131      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5132      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5133      & sinph1ph2(maxdouble,maxdouble)
5134       logical lprn /.false./, lprn1 /.false./
5135       etheta=0.0D0
5136 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5137       do i=ithet_start,ithet_end
5138         dethetai=0.0d0
5139         dephii=0.0d0
5140         dephii1=0.0d0
5141         theti2=0.5d0*theta(i)
5142         ityp2=ithetyp(itype(i-1))
5143         do k=1,nntheterm
5144           coskt(k)=dcos(k*theti2)
5145           sinkt(k)=dsin(k*theti2)
5146         enddo
5147         if (i.gt.3) then
5148 #ifdef OSF
5149           phii=phi(i)
5150           if (phii.ne.phii) phii=150.0
5151 #else
5152           phii=phi(i)
5153 #endif
5154           ityp1=ithetyp(itype(i-2))
5155           do k=1,nsingle
5156             cosph1(k)=dcos(k*phii)
5157             sinph1(k)=dsin(k*phii)
5158           enddo
5159         else
5160           phii=0.0d0
5161           ityp1=nthetyp+1
5162           do k=1,nsingle
5163             cosph1(k)=0.0d0
5164             sinph1(k)=0.0d0
5165           enddo
5166         endif
5167         if (i.lt.nres) then
5168 #ifdef OSF
5169           phii1=phi(i+1)
5170           if (phii1.ne.phii1) phii1=150.0
5171           phii1=pinorm(phii1)
5172 #else
5173           phii1=phi(i+1)
5174 #endif
5175           ityp3=ithetyp(itype(i))
5176           do k=1,nsingle
5177             cosph2(k)=dcos(k*phii1)
5178             sinph2(k)=dsin(k*phii1)
5179           enddo
5180         else
5181           phii1=0.0d0
5182           ityp3=nthetyp+1
5183           do k=1,nsingle
5184             cosph2(k)=0.0d0
5185             sinph2(k)=0.0d0
5186           enddo
5187         endif
5188 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5189 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5190 c        call flush(iout)
5191         ethetai=aa0thet(ityp1,ityp2,ityp3)
5192         do k=1,ndouble
5193           do l=1,k-1
5194             ccl=cosph1(l)*cosph2(k-l)
5195             ssl=sinph1(l)*sinph2(k-l)
5196             scl=sinph1(l)*cosph2(k-l)
5197             csl=cosph1(l)*sinph2(k-l)
5198             cosph1ph2(l,k)=ccl-ssl
5199             cosph1ph2(k,l)=ccl+ssl
5200             sinph1ph2(l,k)=scl+csl
5201             sinph1ph2(k,l)=scl-csl
5202           enddo
5203         enddo
5204         if (lprn) then
5205         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5206      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5207         write (iout,*) "coskt and sinkt"
5208         do k=1,nntheterm
5209           write (iout,*) k,coskt(k),sinkt(k)
5210         enddo
5211         endif
5212         do k=1,ntheterm
5213           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
5214           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
5215      &      *coskt(k)
5216           if (lprn)
5217      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
5218      &     " ethetai",ethetai
5219         enddo
5220         if (lprn) then
5221         write (iout,*) "cosph and sinph"
5222         do k=1,nsingle
5223           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5224         enddo
5225         write (iout,*) "cosph1ph2 and sinph2ph2"
5226         do k=2,ndouble
5227           do l=1,k-1
5228             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5229      &         sinph1ph2(l,k),sinph1ph2(k,l)
5230           enddo
5231         enddo
5232         write(iout,*) "ethetai",ethetai
5233         endif
5234         do m=1,ntheterm2
5235           do k=1,nsingle
5236             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
5237      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
5238      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
5239      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
5240             ethetai=ethetai+sinkt(m)*aux
5241             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5242             dephii=dephii+k*sinkt(m)*(
5243      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
5244      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
5245             dephii1=dephii1+k*sinkt(m)*(
5246      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
5247      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
5248             if (lprn)
5249      &      write (iout,*) "m",m," k",k," bbthet",
5250      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
5251      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
5252      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
5253      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5254           enddo
5255         enddo
5256         if (lprn)
5257      &  write(iout,*) "ethetai",ethetai
5258         do m=1,ntheterm3
5259           do k=2,ndouble
5260             do l=1,k-1
5261               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5262      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
5263      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5264      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
5265               ethetai=ethetai+sinkt(m)*aux
5266               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5267               dephii=dephii+l*sinkt(m)*(
5268      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
5269      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5270      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5271      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5272               dephii1=dephii1+(k-l)*sinkt(m)*(
5273      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5274      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5275      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5276      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5277               if (lprn) then
5278               write (iout,*) "m",m," k",k," l",l," ffthet",
5279      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5280      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5281      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5282      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5283               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5284      &            cosph1ph2(k,l)*sinkt(m),
5285      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5286               endif
5287             enddo
5288           enddo
5289         enddo
5290 10      continue
5291         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5292      &   i,theta(i)*rad2deg,phii*rad2deg,
5293      &   phii1*rad2deg,ethetai
5294         etheta=etheta+ethetai
5295         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5296         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5297         gloc(nphi+i-2,icg)=wang*dethetai
5298       enddo
5299       return
5300       end
5301 #endif
5302 #ifdef CRYST_SC
5303 c-----------------------------------------------------------------------------
5304       subroutine esc(escloc)
5305 C Calculate the local energy of a side chain and its derivatives in the
5306 C corresponding virtual-bond valence angles THETA and the spherical angles
5307 C ALPHA and OMEGA.
5308       implicit real*8 (a-h,o-z)
5309       include 'DIMENSIONS'
5310       include 'DIMENSIONS.ZSCOPT'
5311       include 'COMMON.GEO'
5312       include 'COMMON.LOCAL'
5313       include 'COMMON.VAR'
5314       include 'COMMON.INTERACT'
5315       include 'COMMON.DERIV'
5316       include 'COMMON.CHAIN'
5317       include 'COMMON.IOUNITS'
5318       include 'COMMON.NAMES'
5319       include 'COMMON.FFIELD'
5320       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5321      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5322       common /sccalc/ time11,time12,time112,theti,it,nlobit
5323       delta=0.02d0*pi
5324       escloc=0.0D0
5325 c     write (iout,'(a)') 'ESC'
5326       do i=loc_start,loc_end
5327         it=itype(i)
5328         if (it.eq.10) goto 1
5329         nlobit=nlob(it)
5330 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5331 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5332         theti=theta(i+1)-pipol
5333         x(1)=dtan(theti)
5334         x(2)=alph(i)
5335         x(3)=omeg(i)
5336 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5337
5338         if (x(2).gt.pi-delta) then
5339           xtemp(1)=x(1)
5340           xtemp(2)=pi-delta
5341           xtemp(3)=x(3)
5342           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5343           xtemp(2)=pi
5344           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5345           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5346      &        escloci,dersc(2))
5347           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5348      &        ddersc0(1),dersc(1))
5349           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5350      &        ddersc0(3),dersc(3))
5351           xtemp(2)=pi-delta
5352           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5353           xtemp(2)=pi
5354           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5355           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5356      &            dersc0(2),esclocbi,dersc02)
5357           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5358      &            dersc12,dersc01)
5359           call splinthet(x(2),0.5d0*delta,ss,ssd)
5360           dersc0(1)=dersc01
5361           dersc0(2)=dersc02
5362           dersc0(3)=0.0d0
5363           do k=1,3
5364             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5365           enddo
5366           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5367 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5368 c    &             esclocbi,ss,ssd
5369           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5370 c         escloci=esclocbi
5371 c         write (iout,*) escloci
5372         else if (x(2).lt.delta) then
5373           xtemp(1)=x(1)
5374           xtemp(2)=delta
5375           xtemp(3)=x(3)
5376           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5377           xtemp(2)=0.0d0
5378           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5379           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5380      &        escloci,dersc(2))
5381           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5382      &        ddersc0(1),dersc(1))
5383           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5384      &        ddersc0(3),dersc(3))
5385           xtemp(2)=delta
5386           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5387           xtemp(2)=0.0d0
5388           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5389           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5390      &            dersc0(2),esclocbi,dersc02)
5391           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5392      &            dersc12,dersc01)
5393           dersc0(1)=dersc01
5394           dersc0(2)=dersc02
5395           dersc0(3)=0.0d0
5396           call splinthet(x(2),0.5d0*delta,ss,ssd)
5397           do k=1,3
5398             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5399           enddo
5400           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5401 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5402 c    &             esclocbi,ss,ssd
5403           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5404 c         write (iout,*) escloci
5405         else
5406           call enesc(x,escloci,dersc,ddummy,.false.)
5407         endif
5408
5409         escloc=escloc+escloci
5410 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5411
5412         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5413      &   wscloc*dersc(1)
5414         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5415         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5416     1   continue
5417       enddo
5418       return
5419       end
5420 C---------------------------------------------------------------------------
5421       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5422       implicit real*8 (a-h,o-z)
5423       include 'DIMENSIONS'
5424       include 'COMMON.GEO'
5425       include 'COMMON.LOCAL'
5426       include 'COMMON.IOUNITS'
5427       common /sccalc/ time11,time12,time112,theti,it,nlobit
5428       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5429       double precision contr(maxlob,-1:1)
5430       logical mixed
5431 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5432         escloc_i=0.0D0
5433         do j=1,3
5434           dersc(j)=0.0D0
5435           if (mixed) ddersc(j)=0.0d0
5436         enddo
5437         x3=x(3)
5438
5439 C Because of periodicity of the dependence of the SC energy in omega we have
5440 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5441 C To avoid underflows, first compute & store the exponents.
5442
5443         do iii=-1,1
5444
5445           x(3)=x3+iii*dwapi
5446
5447           do j=1,nlobit
5448             do k=1,3
5449               z(k)=x(k)-censc(k,j,it)
5450             enddo
5451             do k=1,3
5452               Axk=0.0D0
5453               do l=1,3
5454                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5455               enddo
5456               Ax(k,j,iii)=Axk
5457             enddo
5458             expfac=0.0D0
5459             do k=1,3
5460               expfac=expfac+Ax(k,j,iii)*z(k)
5461             enddo
5462             contr(j,iii)=expfac
5463           enddo ! j
5464
5465         enddo ! iii
5466
5467         x(3)=x3
5468 C As in the case of ebend, we want to avoid underflows in exponentiation and
5469 C subsequent NaNs and INFs in energy calculation.
5470 C Find the largest exponent
5471         emin=contr(1,-1)
5472         do iii=-1,1
5473           do j=1,nlobit
5474             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5475           enddo
5476         enddo
5477         emin=0.5D0*emin
5478 cd      print *,'it=',it,' emin=',emin
5479
5480 C Compute the contribution to SC energy and derivatives
5481         do iii=-1,1
5482
5483           do j=1,nlobit
5484             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5485 cd          print *,'j=',j,' expfac=',expfac
5486             escloc_i=escloc_i+expfac
5487             do k=1,3
5488               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5489             enddo
5490             if (mixed) then
5491               do k=1,3,2
5492                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5493      &            +gaussc(k,2,j,it))*expfac
5494               enddo
5495             endif
5496           enddo
5497
5498         enddo ! iii
5499
5500         dersc(1)=dersc(1)/cos(theti)**2
5501         ddersc(1)=ddersc(1)/cos(theti)**2
5502         ddersc(3)=ddersc(3)
5503
5504         escloci=-(dlog(escloc_i)-emin)
5505         do j=1,3
5506           dersc(j)=dersc(j)/escloc_i
5507         enddo
5508         if (mixed) then
5509           do j=1,3,2
5510             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5511           enddo
5512         endif
5513       return
5514       end
5515 C------------------------------------------------------------------------------
5516       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5517       implicit real*8 (a-h,o-z)
5518       include 'DIMENSIONS'
5519       include 'COMMON.GEO'
5520       include 'COMMON.LOCAL'
5521       include 'COMMON.IOUNITS'
5522       common /sccalc/ time11,time12,time112,theti,it,nlobit
5523       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5524       double precision contr(maxlob)
5525       logical mixed
5526
5527       escloc_i=0.0D0
5528
5529       do j=1,3
5530         dersc(j)=0.0D0
5531       enddo
5532
5533       do j=1,nlobit
5534         do k=1,2
5535           z(k)=x(k)-censc(k,j,it)
5536         enddo
5537         z(3)=dwapi
5538         do k=1,3
5539           Axk=0.0D0
5540           do l=1,3
5541             Axk=Axk+gaussc(l,k,j,it)*z(l)
5542           enddo
5543           Ax(k,j)=Axk
5544         enddo
5545         expfac=0.0D0
5546         do k=1,3
5547           expfac=expfac+Ax(k,j)*z(k)
5548         enddo
5549         contr(j)=expfac
5550       enddo ! j
5551
5552 C As in the case of ebend, we want to avoid underflows in exponentiation and
5553 C subsequent NaNs and INFs in energy calculation.
5554 C Find the largest exponent
5555       emin=contr(1)
5556       do j=1,nlobit
5557         if (emin.gt.contr(j)) emin=contr(j)
5558       enddo
5559       emin=0.5D0*emin
5560
5561 C Compute the contribution to SC energy and derivatives
5562
5563       dersc12=0.0d0
5564       do j=1,nlobit
5565         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5566         escloc_i=escloc_i+expfac
5567         do k=1,2
5568           dersc(k)=dersc(k)+Ax(k,j)*expfac
5569         enddo
5570         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5571      &            +gaussc(1,2,j,it))*expfac
5572         dersc(3)=0.0d0
5573       enddo
5574
5575       dersc(1)=dersc(1)/cos(theti)**2
5576       dersc12=dersc12/cos(theti)**2
5577       escloci=-(dlog(escloc_i)-emin)
5578       do j=1,2
5579         dersc(j)=dersc(j)/escloc_i
5580       enddo
5581       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5582       return
5583       end
5584 #else
5585 c----------------------------------------------------------------------------------
5586       subroutine esc(escloc)
5587 C Calculate the local energy of a side chain and its derivatives in the
5588 C corresponding virtual-bond valence angles THETA and the spherical angles
5589 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5590 C added by Urszula Kozlowska. 07/11/2007
5591 C
5592       implicit real*8 (a-h,o-z)
5593       include 'DIMENSIONS'
5594       include 'DIMENSIONS.ZSCOPT'
5595       include 'COMMON.GEO'
5596       include 'COMMON.LOCAL'
5597       include 'COMMON.VAR'
5598       include 'COMMON.SCROT'
5599       include 'COMMON.INTERACT'
5600       include 'COMMON.DERIV'
5601       include 'COMMON.CHAIN'
5602       include 'COMMON.IOUNITS'
5603       include 'COMMON.NAMES'
5604       include 'COMMON.FFIELD'
5605       include 'COMMON.CONTROL'
5606       include 'COMMON.VECTORS'
5607       double precision x_prime(3),y_prime(3),z_prime(3)
5608      &    , sumene,dsc_i,dp2_i,x(65),
5609      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5610      &    de_dxx,de_dyy,de_dzz,de_dt
5611       double precision s1_t,s1_6_t,s2_t,s2_6_t
5612       double precision
5613      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5614      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5615      & dt_dCi(3),dt_dCi1(3)
5616       common /sccalc/ time11,time12,time112,theti,it,nlobit
5617       delta=0.02d0*pi
5618       escloc=0.0D0
5619       do i=loc_start,loc_end
5620         costtab(i+1) =dcos(theta(i+1))
5621         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5622         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5623         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5624         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5625         cosfac=dsqrt(cosfac2)
5626         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5627         sinfac=dsqrt(sinfac2)
5628         it=itype(i)
5629         if (it.eq.10) goto 1
5630 c
5631 C  Compute the axes of tghe local cartesian coordinates system; store in
5632 c   x_prime, y_prime and z_prime
5633 c
5634         do j=1,3
5635           x_prime(j) = 0.00
5636           y_prime(j) = 0.00
5637           z_prime(j) = 0.00
5638         enddo
5639 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5640 C     &   dc_norm(3,i+nres)
5641         do j = 1,3
5642           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5643           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5644         enddo
5645         do j = 1,3
5646           z_prime(j) = -uz(j,i-1)
5647         enddo
5648 c       write (2,*) "i",i
5649 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5650 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5651 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5652 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5653 c      & " xy",scalar(x_prime(1),y_prime(1)),
5654 c      & " xz",scalar(x_prime(1),z_prime(1)),
5655 c      & " yy",scalar(y_prime(1),y_prime(1)),
5656 c      & " yz",scalar(y_prime(1),z_prime(1)),
5657 c      & " zz",scalar(z_prime(1),z_prime(1))
5658 c
5659 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5660 C to local coordinate system. Store in xx, yy, zz.
5661 c
5662         xx=0.0d0
5663         yy=0.0d0
5664         zz=0.0d0
5665         do j = 1,3
5666           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5667           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5668           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5669         enddo
5670
5671         xxtab(i)=xx
5672         yytab(i)=yy
5673         zztab(i)=zz
5674 C
5675 C Compute the energy of the ith side cbain
5676 C
5677 c        write (2,*) "xx",xx," yy",yy," zz",zz
5678         it=itype(i)
5679         do j = 1,65
5680           x(j) = sc_parmin(j,it)
5681         enddo
5682 #ifdef CHECK_COORD
5683 Cc diagnostics - remove later
5684         xx1 = dcos(alph(2))
5685         yy1 = dsin(alph(2))*dcos(omeg(2))
5686         zz1 = -dsin(alph(2))*dsin(omeg(2))
5687         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5688      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5689      &    xx1,yy1,zz1
5690 C,"  --- ", xx_w,yy_w,zz_w
5691 c end diagnostics
5692 #endif
5693         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5694      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5695      &   + x(10)*yy*zz
5696         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5697      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5698      & + x(20)*yy*zz
5699         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5700      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5701      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5702      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5703      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5704      &  +x(40)*xx*yy*zz
5705         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5706      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5707      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5708      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5709      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5710      &  +x(60)*xx*yy*zz
5711         dsc_i   = 0.743d0+x(61)
5712         dp2_i   = 1.9d0+x(62)
5713         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5714      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5715         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5716      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5717         s1=(1+x(63))/(0.1d0 + dscp1)
5718         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5719         s2=(1+x(65))/(0.1d0 + dscp2)
5720         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5721         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5722      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5723 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5724 c     &   sumene4,
5725 c     &   dscp1,dscp2,sumene
5726 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5727         escloc = escloc + sumene
5728 c        write (2,*) "escloc",escloc
5729         if (.not. calc_grad) goto 1
5730 #ifdef DEBUG
5731 C
5732 C This section to check the numerical derivatives of the energy of ith side
5733 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5734 C #define DEBUG in the code to turn it on.
5735 C
5736         write (2,*) "sumene               =",sumene
5737         aincr=1.0d-7
5738         xxsave=xx
5739         xx=xx+aincr
5740         write (2,*) xx,yy,zz
5741         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5742         de_dxx_num=(sumenep-sumene)/aincr
5743         xx=xxsave
5744         write (2,*) "xx+ sumene from enesc=",sumenep
5745         yysave=yy
5746         yy=yy+aincr
5747         write (2,*) xx,yy,zz
5748         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5749         de_dyy_num=(sumenep-sumene)/aincr
5750         yy=yysave
5751         write (2,*) "yy+ sumene from enesc=",sumenep
5752         zzsave=zz
5753         zz=zz+aincr
5754         write (2,*) xx,yy,zz
5755         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5756         de_dzz_num=(sumenep-sumene)/aincr
5757         zz=zzsave
5758         write (2,*) "zz+ sumene from enesc=",sumenep
5759         costsave=cost2tab(i+1)
5760         sintsave=sint2tab(i+1)
5761         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5762         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5763         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5764         de_dt_num=(sumenep-sumene)/aincr
5765         write (2,*) " t+ sumene from enesc=",sumenep
5766         cost2tab(i+1)=costsave
5767         sint2tab(i+1)=sintsave
5768 C End of diagnostics section.
5769 #endif
5770 C
5771 C Compute the gradient of esc
5772 C
5773         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5774         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5775         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5776         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5777         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5778         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5779         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5780         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5781         pom1=(sumene3*sint2tab(i+1)+sumene1)
5782      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5783         pom2=(sumene4*cost2tab(i+1)+sumene2)
5784      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5785         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5786         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5787      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5788      &  +x(40)*yy*zz
5789         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5790         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5791      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5792      &  +x(60)*yy*zz
5793         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5794      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5795      &        +(pom1+pom2)*pom_dx
5796 #ifdef DEBUG
5797         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5798 #endif
5799 C
5800         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5801         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5802      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5803      &  +x(40)*xx*zz
5804         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5805         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5806      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5807      &  +x(59)*zz**2 +x(60)*xx*zz
5808         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5809      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5810      &        +(pom1-pom2)*pom_dy
5811 #ifdef DEBUG
5812         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5813 #endif
5814 C
5815         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5816      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5817      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5818      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5819      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5820      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5821      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5822      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5823 #ifdef DEBUG
5824         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5825 #endif
5826 C
5827         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5828      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5829      &  +pom1*pom_dt1+pom2*pom_dt2
5830 #ifdef DEBUG
5831         write(2,*), "de_dt = ", de_dt,de_dt_num
5832 #endif
5833 c
5834 C
5835        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5836        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5837        cosfac2xx=cosfac2*xx
5838        sinfac2yy=sinfac2*yy
5839        do k = 1,3
5840          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5841      &      vbld_inv(i+1)
5842          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5843      &      vbld_inv(i)
5844          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5845          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5846 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5847 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5848 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5849 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5850          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5851          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5852          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5853          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5854          dZZ_Ci1(k)=0.0d0
5855          dZZ_Ci(k)=0.0d0
5856          do j=1,3
5857            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5858            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5859          enddo
5860
5861          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5862          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5863          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5864 c
5865          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5866          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5867        enddo
5868
5869        do k=1,3
5870          dXX_Ctab(k,i)=dXX_Ci(k)
5871          dXX_C1tab(k,i)=dXX_Ci1(k)
5872          dYY_Ctab(k,i)=dYY_Ci(k)
5873          dYY_C1tab(k,i)=dYY_Ci1(k)
5874          dZZ_Ctab(k,i)=dZZ_Ci(k)
5875          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5876          dXX_XYZtab(k,i)=dXX_XYZ(k)
5877          dYY_XYZtab(k,i)=dYY_XYZ(k)
5878          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5879        enddo
5880
5881        do k = 1,3
5882 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5883 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5884 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5885 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5886 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5887 c     &    dt_dci(k)
5888 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5889 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5890          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5891      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5892          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5893      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5894          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5895      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5896        enddo
5897 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5898 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5899
5900 C to check gradient call subroutine check_grad
5901
5902     1 continue
5903       enddo
5904       return
5905       end
5906 #endif
5907 c------------------------------------------------------------------------------
5908       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5909 C
5910 C This procedure calculates two-body contact function g(rij) and its derivative:
5911 C
5912 C           eps0ij                                     !       x < -1
5913 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5914 C            0                                         !       x > 1
5915 C
5916 C where x=(rij-r0ij)/delta
5917 C
5918 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5919 C
5920       implicit none
5921       double precision rij,r0ij,eps0ij,fcont,fprimcont
5922       double precision x,x2,x4,delta
5923 c     delta=0.02D0*r0ij
5924 c      delta=0.2D0*r0ij
5925       x=(rij-r0ij)/delta
5926       if (x.lt.-1.0D0) then
5927         fcont=eps0ij
5928         fprimcont=0.0D0
5929       else if (x.le.1.0D0) then
5930         x2=x*x
5931         x4=x2*x2
5932         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5933         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5934       else
5935         fcont=0.0D0
5936         fprimcont=0.0D0
5937       endif
5938       return
5939       end
5940 c------------------------------------------------------------------------------
5941       subroutine splinthet(theti,delta,ss,ssder)
5942       implicit real*8 (a-h,o-z)
5943       include 'DIMENSIONS'
5944       include 'DIMENSIONS.ZSCOPT'
5945       include 'COMMON.VAR'
5946       include 'COMMON.GEO'
5947       thetup=pi-delta
5948       thetlow=delta
5949       if (theti.gt.pipol) then
5950         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5951       else
5952         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5953         ssder=-ssder
5954       endif
5955       return
5956       end
5957 c------------------------------------------------------------------------------
5958       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5959       implicit none
5960       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5961       double precision ksi,ksi2,ksi3,a1,a2,a3
5962       a1=fprim0*delta/(f1-f0)
5963       a2=3.0d0-2.0d0*a1
5964       a3=a1-2.0d0
5965       ksi=(x-x0)/delta
5966       ksi2=ksi*ksi
5967       ksi3=ksi2*ksi
5968       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5969       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5970       return
5971       end
5972 c------------------------------------------------------------------------------
5973       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5974       implicit none
5975       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5976       double precision ksi,ksi2,ksi3,a1,a2,a3
5977       ksi=(x-x0)/delta
5978       ksi2=ksi*ksi
5979       ksi3=ksi2*ksi
5980       a1=fprim0x*delta
5981       a2=3*(f1x-f0x)-2*fprim0x*delta
5982       a3=fprim0x*delta-2*(f1x-f0x)
5983       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5984       return
5985       end
5986 C-----------------------------------------------------------------------------
5987 #ifdef CRYST_TOR
5988 C-----------------------------------------------------------------------------
5989       subroutine etor(etors,edihcnstr,fact)
5990       implicit real*8 (a-h,o-z)
5991       include 'DIMENSIONS'
5992       include 'DIMENSIONS.ZSCOPT'
5993       include 'COMMON.VAR'
5994       include 'COMMON.GEO'
5995       include 'COMMON.LOCAL'
5996       include 'COMMON.TORSION'
5997       include 'COMMON.INTERACT'
5998       include 'COMMON.DERIV'
5999       include 'COMMON.CHAIN'
6000       include 'COMMON.NAMES'
6001       include 'COMMON.IOUNITS'
6002       include 'COMMON.FFIELD'
6003       include 'COMMON.TORCNSTR'
6004       logical lprn
6005 C Set lprn=.true. for debugging
6006       lprn=.false.
6007 c      lprn=.true.
6008       etors=0.0D0
6009       do i=iphi_start,iphi_end
6010         itori=itortyp(itype(i-2))
6011         itori1=itortyp(itype(i-1))
6012         phii=phi(i)
6013         gloci=0.0D0
6014 C Proline-Proline pair is a special case...
6015         if (itori.eq.3 .and. itori1.eq.3) then
6016           if (phii.gt.-dwapi3) then
6017             cosphi=dcos(3*phii)
6018             fac=1.0D0/(1.0D0-cosphi)
6019             etorsi=v1(1,3,3)*fac
6020             etorsi=etorsi+etorsi
6021             etors=etors+etorsi-v1(1,3,3)
6022             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6023           endif
6024           do j=1,3
6025             v1ij=v1(j+1,itori,itori1)
6026             v2ij=v2(j+1,itori,itori1)
6027             cosphi=dcos(j*phii)
6028             sinphi=dsin(j*phii)
6029             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6030             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6031           enddo
6032         else
6033           do j=1,nterm_old
6034             v1ij=v1(j,itori,itori1)
6035             v2ij=v2(j,itori,itori1)
6036             cosphi=dcos(j*phii)
6037             sinphi=dsin(j*phii)
6038             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6039             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6040           enddo
6041         endif
6042         if (lprn)
6043      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6044      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6045      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6046         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6047 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6048       enddo
6049 ! 6/20/98 - dihedral angle constraints
6050       edihcnstr=0.0d0
6051       do i=1,ndih_constr
6052         itori=idih_constr(i)
6053         phii=phi(itori)
6054         difi=phii-phi0(i)
6055         if (difi.gt.drange(i)) then
6056           difi=difi-drange(i)
6057           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6058           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6059         else if (difi.lt.-drange(i)) then
6060           difi=difi+drange(i)
6061           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6062           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6063         endif
6064 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6065 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6066       enddo
6067 !      write (iout,*) 'edihcnstr',edihcnstr
6068       return
6069       end
6070 c------------------------------------------------------------------------------
6071 #else
6072       subroutine etor(etors,edihcnstr,fact)
6073       implicit real*8 (a-h,o-z)
6074       include 'DIMENSIONS'
6075       include 'DIMENSIONS.ZSCOPT'
6076       include 'COMMON.VAR'
6077       include 'COMMON.GEO'
6078       include 'COMMON.LOCAL'
6079       include 'COMMON.TORSION'
6080       include 'COMMON.INTERACT'
6081       include 'COMMON.DERIV'
6082       include 'COMMON.CHAIN'
6083       include 'COMMON.NAMES'
6084       include 'COMMON.IOUNITS'
6085       include 'COMMON.FFIELD'
6086       include 'COMMON.TORCNSTR'
6087       logical lprn
6088 C Set lprn=.true. for debugging
6089       lprn=.false.
6090 c      lprn=.true.
6091       etors=0.0D0
6092       do i=iphi_start,iphi_end
6093         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6094         itori=itortyp(itype(i-2))
6095         itori1=itortyp(itype(i-1))
6096         phii=phi(i)
6097         gloci=0.0D0
6098 C Regular cosine and sine terms
6099         do j=1,nterm(itori,itori1)
6100           v1ij=v1(j,itori,itori1)
6101           v2ij=v2(j,itori,itori1)
6102           cosphi=dcos(j*phii)
6103           sinphi=dsin(j*phii)
6104           etors=etors+v1ij*cosphi+v2ij*sinphi
6105           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6106         enddo
6107 C Lorentz terms
6108 C                         v1
6109 C  E = SUM ----------------------------------- - v1
6110 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6111 C
6112         cosphi=dcos(0.5d0*phii)
6113         sinphi=dsin(0.5d0*phii)
6114         do j=1,nlor(itori,itori1)
6115           vl1ij=vlor1(j,itori,itori1)
6116           vl2ij=vlor2(j,itori,itori1)
6117           vl3ij=vlor3(j,itori,itori1)
6118           pom=vl2ij*cosphi+vl3ij*sinphi
6119           pom1=1.0d0/(pom*pom+1.0d0)
6120           etors=etors+vl1ij*pom1
6121           pom=-pom*pom1*pom1
6122           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6123         enddo
6124 C Subtract the constant term
6125         etors=etors-v0(itori,itori1)
6126         if (lprn)
6127      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6128      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6129      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6130         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6131 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6132  1215   continue
6133       enddo
6134 ! 6/20/98 - dihedral angle constraints
6135       edihcnstr=0.0d0
6136       do i=1,ndih_constr
6137         itori=idih_constr(i)
6138         phii=phi(itori)
6139         difi=pinorm(phii-phi0(i))
6140         edihi=0.0d0
6141         if (difi.gt.drange(i)) then
6142           difi=difi-drange(i)
6143           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6144           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6145           edihi=0.25d0*ftors*difi**4
6146         else if (difi.lt.-drange(i)) then
6147           difi=difi+drange(i)
6148           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6149           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6150           edihi=0.25d0*ftors*difi**4
6151         else
6152           difi=0.0d0
6153         endif
6154 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
6155 c     &    drange(i),edihi
6156 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6157 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6158       enddo
6159 !      write (iout,*) 'edihcnstr',edihcnstr
6160       return
6161       end
6162 c----------------------------------------------------------------------------
6163       subroutine etor_d(etors_d,fact2)
6164 C 6/23/01 Compute double torsional energy
6165       implicit real*8 (a-h,o-z)
6166       include 'DIMENSIONS'
6167       include 'DIMENSIONS.ZSCOPT'
6168       include 'COMMON.VAR'
6169       include 'COMMON.GEO'
6170       include 'COMMON.LOCAL'
6171       include 'COMMON.TORSION'
6172       include 'COMMON.INTERACT'
6173       include 'COMMON.DERIV'
6174       include 'COMMON.CHAIN'
6175       include 'COMMON.NAMES'
6176       include 'COMMON.IOUNITS'
6177       include 'COMMON.FFIELD'
6178       include 'COMMON.TORCNSTR'
6179       logical lprn
6180 C Set lprn=.true. for debugging
6181       lprn=.false.
6182 c     lprn=.true.
6183       etors_d=0.0D0
6184       do i=iphi_start,iphi_end-1
6185         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6186      &     goto 1215
6187         itori=itortyp(itype(i-2))
6188         itori1=itortyp(itype(i-1))
6189         itori2=itortyp(itype(i))
6190         phii=phi(i)
6191         phii1=phi(i+1)
6192         gloci1=0.0D0
6193         gloci2=0.0D0
6194 C Regular cosine and sine terms
6195         do j=1,ntermd_1(itori,itori1,itori2)
6196           v1cij=v1c(1,j,itori,itori1,itori2)
6197           v1sij=v1s(1,j,itori,itori1,itori2)
6198           v2cij=v1c(2,j,itori,itori1,itori2)
6199           v2sij=v1s(2,j,itori,itori1,itori2)
6200           cosphi1=dcos(j*phii)
6201           sinphi1=dsin(j*phii)
6202           cosphi2=dcos(j*phii1)
6203           sinphi2=dsin(j*phii1)
6204           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6205      &     v2cij*cosphi2+v2sij*sinphi2
6206           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6207           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6208         enddo
6209         do k=2,ntermd_2(itori,itori1,itori2)
6210           do l=1,k-1
6211             v1cdij = v2c(k,l,itori,itori1,itori2)
6212             v2cdij = v2c(l,k,itori,itori1,itori2)
6213             v1sdij = v2s(k,l,itori,itori1,itori2)
6214             v2sdij = v2s(l,k,itori,itori1,itori2)
6215             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6216             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6217             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6218             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6219             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6220      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6221             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6222      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6223             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6224      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6225           enddo
6226         enddo
6227         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6228         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6229  1215   continue
6230       enddo
6231       return
6232       end
6233 #endif
6234 c------------------------------------------------------------------------------
6235       subroutine eback_sc_corr(esccor)
6236 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6237 c        conformational states; temporarily implemented as differences
6238 c        between UNRES torsional potentials (dependent on three types of
6239 c        residues) and the torsional potentials dependent on all 20 types
6240 c        of residues computed from AM1 energy surfaces of terminally-blocked
6241 c        amino-acid residues.
6242       implicit real*8 (a-h,o-z)
6243       include 'DIMENSIONS'
6244       include 'DIMENSIONS.ZSCOPT'
6245       include 'COMMON.VAR'
6246       include 'COMMON.GEO'
6247       include 'COMMON.LOCAL'
6248       include 'COMMON.TORSION'
6249       include 'COMMON.SCCOR'
6250       include 'COMMON.INTERACT'
6251       include 'COMMON.DERIV'
6252       include 'COMMON.CHAIN'
6253       include 'COMMON.NAMES'
6254       include 'COMMON.IOUNITS'
6255       include 'COMMON.FFIELD'
6256       include 'COMMON.CONTROL'
6257       logical lprn
6258 C Set lprn=.true. for debugging
6259       lprn=.false.
6260 c      lprn=.true.
6261 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
6262       esccor=0.0D0
6263       do i=itau_start,itau_end
6264         esccor_ii=0.0D0
6265         isccori=isccortyp(itype(i-2))
6266         isccori1=isccortyp(itype(i-1))
6267         phii=phi(i)
6268 cccc  Added 9 May 2012
6269 cc Tauangle is torsional engle depending on the value of first digit
6270 c(see comment below)
6271 cc Omicron is flat angle depending on the value of first digit
6272 c(see comment below)
6273
6274
6275         do intertyp=1,3 !intertyp
6276 cc Added 09 May 2012 (Adasko)
6277 cc  Intertyp means interaction type of backbone mainchain correlation:
6278 c   1 = SC...Ca...Ca...Ca
6279 c   2 = Ca...Ca...Ca...SC
6280 c   3 = SC...Ca...Ca...SCi
6281         gloci=0.0D0
6282         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6283      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6284      &      (itype(i-1).eq.21)))
6285      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6286      &     .or.(itype(i-2).eq.21)))
6287      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6288      &      (itype(i-1).eq.21)))) cycle
6289         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6290         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6291      & cycle
6292         do j=1,nterm_sccor(isccori,isccori1)
6293           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6294           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6295           cosphi=dcos(j*tauangle(intertyp,i))
6296           sinphi=dsin(j*tauangle(intertyp,i))
6297           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6298           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6299         enddo
6300         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6301 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6302 c     &gloc_sc(intertyp,i-3,icg)
6303         if (lprn)
6304      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6305      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6306      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6307      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6308         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6309        enddo !intertyp
6310       enddo
6311 c        do i=1,nres
6312 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6313 c        enddo
6314       return
6315       end
6316 c------------------------------------------------------------------------------
6317       subroutine multibody(ecorr)
6318 C This subroutine calculates multi-body contributions to energy following
6319 C the idea of Skolnick et al. If side chains I and J make a contact and
6320 C at the same time side chains I+1 and J+1 make a contact, an extra
6321 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6322       implicit real*8 (a-h,o-z)
6323       include 'DIMENSIONS'
6324       include 'COMMON.IOUNITS'
6325       include 'COMMON.DERIV'
6326       include 'COMMON.INTERACT'
6327       include 'COMMON.CONTACTS'
6328       double precision gx(3),gx1(3)
6329       logical lprn
6330
6331 C Set lprn=.true. for debugging
6332       lprn=.false.
6333
6334       if (lprn) then
6335         write (iout,'(a)') 'Contact function values:'
6336         do i=nnt,nct-2
6337           write (iout,'(i2,20(1x,i2,f10.5))')
6338      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6339         enddo
6340       endif
6341       ecorr=0.0D0
6342       do i=nnt,nct
6343         do j=1,3
6344           gradcorr(j,i)=0.0D0
6345           gradxorr(j,i)=0.0D0
6346         enddo
6347       enddo
6348       do i=nnt,nct-2
6349
6350         DO ISHIFT = 3,4
6351
6352         i1=i+ishift
6353         num_conti=num_cont(i)
6354         num_conti1=num_cont(i1)
6355         do jj=1,num_conti
6356           j=jcont(jj,i)
6357           do kk=1,num_conti1
6358             j1=jcont(kk,i1)
6359             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6360 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6361 cd   &                   ' ishift=',ishift
6362 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6363 C The system gains extra energy.
6364               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6365             endif   ! j1==j+-ishift
6366           enddo     ! kk
6367         enddo       ! jj
6368
6369         ENDDO ! ISHIFT
6370
6371       enddo         ! i
6372       return
6373       end
6374 c------------------------------------------------------------------------------
6375       double precision function esccorr(i,j,k,l,jj,kk)
6376       implicit real*8 (a-h,o-z)
6377       include 'DIMENSIONS'
6378       include 'COMMON.IOUNITS'
6379       include 'COMMON.DERIV'
6380       include 'COMMON.INTERACT'
6381       include 'COMMON.CONTACTS'
6382       double precision gx(3),gx1(3)
6383       logical lprn
6384       lprn=.false.
6385       eij=facont(jj,i)
6386       ekl=facont(kk,k)
6387 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6388 C Calculate the multi-body contribution to energy.
6389 C Calculate multi-body contributions to the gradient.
6390 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6391 cd   & k,l,(gacont(m,kk,k),m=1,3)
6392       do m=1,3
6393         gx(m) =ekl*gacont(m,jj,i)
6394         gx1(m)=eij*gacont(m,kk,k)
6395         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6396         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6397         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6398         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6399       enddo
6400       do m=i,j-1
6401         do ll=1,3
6402           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6403         enddo
6404       enddo
6405       do m=k,l-1
6406         do ll=1,3
6407           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6408         enddo
6409       enddo
6410       esccorr=-eij*ekl
6411       return
6412       end
6413 c------------------------------------------------------------------------------
6414 #ifdef MPL
6415       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
6416       implicit real*8 (a-h,o-z)
6417       include 'DIMENSIONS'
6418       integer dimen1,dimen2,atom,indx
6419       double precision buffer(dimen1,dimen2)
6420       double precision zapas
6421       common /contacts_hb/ zapas(3,20,maxres,7),
6422      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6423      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6424       num_kont=num_cont_hb(atom)
6425       do i=1,num_kont
6426         do k=1,7
6427           do j=1,3
6428             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
6429           enddo ! j
6430         enddo ! k
6431         buffer(i,indx+22)=facont_hb(i,atom)
6432         buffer(i,indx+23)=ees0p(i,atom)
6433         buffer(i,indx+24)=ees0m(i,atom)
6434         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
6435       enddo ! i
6436       buffer(1,indx+26)=dfloat(num_kont)
6437       return
6438       end
6439 c------------------------------------------------------------------------------
6440       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
6441       implicit real*8 (a-h,o-z)
6442       include 'DIMENSIONS'
6443       integer dimen1,dimen2,atom,indx
6444       double precision buffer(dimen1,dimen2)
6445       double precision zapas
6446       common /contacts_hb/ zapas(3,20,maxres,7),
6447      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6448      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6449       num_kont=buffer(1,indx+26)
6450       num_kont_old=num_cont_hb(atom)
6451       num_cont_hb(atom)=num_kont+num_kont_old
6452       do i=1,num_kont
6453         ii=i+num_kont_old
6454         do k=1,7
6455           do j=1,3
6456             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
6457           enddo ! j
6458         enddo ! k
6459         facont_hb(ii,atom)=buffer(i,indx+22)
6460         ees0p(ii,atom)=buffer(i,indx+23)
6461         ees0m(ii,atom)=buffer(i,indx+24)
6462         jcont_hb(ii,atom)=buffer(i,indx+25)
6463       enddo ! i
6464       return
6465       end
6466 c------------------------------------------------------------------------------
6467 #endif
6468       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6469 C This subroutine calculates multi-body contributions to hydrogen-bonding
6470       implicit real*8 (a-h,o-z)
6471       include 'DIMENSIONS'
6472       include 'DIMENSIONS.ZSCOPT'
6473       include 'COMMON.IOUNITS'
6474 #ifdef MPL
6475       include 'COMMON.INFO'
6476 #endif
6477       include 'COMMON.FFIELD'
6478       include 'COMMON.DERIV'
6479       include 'COMMON.INTERACT'
6480       include 'COMMON.CONTACTS'
6481 #ifdef MPL
6482       parameter (max_cont=maxconts)
6483       parameter (max_dim=2*(8*3+2))
6484       parameter (msglen1=max_cont*max_dim*4)
6485       parameter (msglen2=2*msglen1)
6486       integer source,CorrelType,CorrelID,Error
6487       double precision buffer(max_cont,max_dim)
6488 #endif
6489       double precision gx(3),gx1(3)
6490       logical lprn,ldone
6491
6492 C Set lprn=.true. for debugging
6493       lprn=.false.
6494 #ifdef MPL
6495       n_corr=0
6496       n_corr1=0
6497       if (fgProcs.le.1) goto 30
6498       if (lprn) then
6499         write (iout,'(a)') 'Contact function values:'
6500         do i=nnt,nct-2
6501           write (iout,'(2i3,50(1x,i2,f5.2))')
6502      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6503      &    j=1,num_cont_hb(i))
6504         enddo
6505       endif
6506 C Caution! Following code assumes that electrostatic interactions concerning
6507 C a given atom are split among at most two processors!
6508       CorrelType=477
6509       CorrelID=MyID+1
6510       ldone=.false.
6511       do i=1,max_cont
6512         do j=1,max_dim
6513           buffer(i,j)=0.0D0
6514         enddo
6515       enddo
6516       mm=mod(MyRank,2)
6517 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6518       if (mm) 20,20,10
6519    10 continue
6520 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6521       if (MyRank.gt.0) then
6522 C Send correlation contributions to the preceding processor
6523         msglen=msglen1
6524         nn=num_cont_hb(iatel_s)
6525         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6526 cd      write (iout,*) 'The BUFFER array:'
6527 cd      do i=1,nn
6528 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6529 cd      enddo
6530         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6531           msglen=msglen2
6532             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6533 C Clear the contacts of the atom passed to the neighboring processor
6534         nn=num_cont_hb(iatel_s+1)
6535 cd      do i=1,nn
6536 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6537 cd      enddo
6538             num_cont_hb(iatel_s)=0
6539         endif
6540 cd      write (iout,*) 'Processor ',MyID,MyRank,
6541 cd   & ' is sending correlation contribution to processor',MyID-1,
6542 cd   & ' msglen=',msglen
6543 cd      write (*,*) 'Processor ',MyID,MyRank,
6544 cd   & ' is sending correlation contribution to processor',MyID-1,
6545 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6546         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6547 cd      write (iout,*) 'Processor ',MyID,
6548 cd   & ' has sent correlation contribution to processor',MyID-1,
6549 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6550 cd      write (*,*) 'Processor ',MyID,
6551 cd   & ' has sent correlation contribution to processor',MyID-1,
6552 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6553         msglen=msglen1
6554       endif ! (MyRank.gt.0)
6555       if (ldone) goto 30
6556       ldone=.true.
6557    20 continue
6558 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6559       if (MyRank.lt.fgProcs-1) then
6560 C Receive correlation contributions from the next processor
6561         msglen=msglen1
6562         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6563 cd      write (iout,*) 'Processor',MyID,
6564 cd   & ' is receiving correlation contribution from processor',MyID+1,
6565 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6566 cd      write (*,*) 'Processor',MyID,
6567 cd   & ' is receiving correlation contribution from processor',MyID+1,
6568 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6569         nbytes=-1
6570         do while (nbytes.le.0)
6571           call mp_probe(MyID+1,CorrelType,nbytes)
6572         enddo
6573 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6574         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6575 cd      write (iout,*) 'Processor',MyID,
6576 cd   & ' has received correlation contribution from processor',MyID+1,
6577 cd   & ' msglen=',msglen,' nbytes=',nbytes
6578 cd      write (iout,*) 'The received BUFFER array:'
6579 cd      do i=1,max_cont
6580 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6581 cd      enddo
6582         if (msglen.eq.msglen1) then
6583           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6584         else if (msglen.eq.msglen2)  then
6585           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6586           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6587         else
6588           write (iout,*)
6589      & 'ERROR!!!! message length changed while processing correlations.'
6590           write (*,*)
6591      & 'ERROR!!!! message length changed while processing correlations.'
6592           call mp_stopall(Error)
6593         endif ! msglen.eq.msglen1
6594       endif ! MyRank.lt.fgProcs-1
6595       if (ldone) goto 30
6596       ldone=.true.
6597       goto 10
6598    30 continue
6599 #endif
6600       if (lprn) then
6601         write (iout,'(a)') 'Contact function values:'
6602         do i=nnt,nct-2
6603           write (iout,'(2i3,50(1x,i2,f5.2))')
6604      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6605      &    j=1,num_cont_hb(i))
6606         enddo
6607       endif
6608       ecorr=0.0D0
6609 C Remove the loop below after debugging !!!
6610       do i=nnt,nct
6611         do j=1,3
6612           gradcorr(j,i)=0.0D0
6613           gradxorr(j,i)=0.0D0
6614         enddo
6615       enddo
6616 C Calculate the local-electrostatic correlation terms
6617       do i=iatel_s,iatel_e+1
6618         i1=i+1
6619         num_conti=num_cont_hb(i)
6620         num_conti1=num_cont_hb(i+1)
6621         do jj=1,num_conti
6622           j=jcont_hb(jj,i)
6623           do kk=1,num_conti1
6624             j1=jcont_hb(kk,i1)
6625 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6626 c     &         ' jj=',jj,' kk=',kk
6627             if (j1.eq.j+1 .or. j1.eq.j-1) then
6628 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6629 C The system gains extra energy.
6630               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6631               n_corr=n_corr+1
6632             else if (j1.eq.j) then
6633 C Contacts I-J and I-(J+1) occur simultaneously.
6634 C The system loses extra energy.
6635 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6636             endif
6637           enddo ! kk
6638           do kk=1,num_conti
6639             j1=jcont_hb(kk,i)
6640 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6641 c    &         ' jj=',jj,' kk=',kk
6642             if (j1.eq.j+1) then
6643 C Contacts I-J and (I+1)-J occur simultaneously.
6644 C The system loses extra energy.
6645 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6646             endif ! j1==j+1
6647           enddo ! kk
6648         enddo ! jj
6649       enddo ! i
6650       return
6651       end
6652 c------------------------------------------------------------------------------
6653       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6654      &  n_corr1)
6655 C This subroutine calculates multi-body contributions to hydrogen-bonding
6656       implicit real*8 (a-h,o-z)
6657       include 'DIMENSIONS'
6658       include 'DIMENSIONS.ZSCOPT'
6659       include 'COMMON.IOUNITS'
6660 #ifdef MPL
6661       include 'COMMON.INFO'
6662 #endif
6663       include 'COMMON.FFIELD'
6664       include 'COMMON.DERIV'
6665       include 'COMMON.INTERACT'
6666       include 'COMMON.CONTACTS'
6667 #ifdef MPL
6668       parameter (max_cont=maxconts)
6669       parameter (max_dim=2*(8*3+2))
6670       parameter (msglen1=max_cont*max_dim*4)
6671       parameter (msglen2=2*msglen1)
6672       integer source,CorrelType,CorrelID,Error
6673       double precision buffer(max_cont,max_dim)
6674 #endif
6675       double precision gx(3),gx1(3)
6676       logical lprn,ldone
6677
6678 C Set lprn=.true. for debugging
6679       lprn=.false.
6680       eturn6=0.0d0
6681 #ifdef MPL
6682       n_corr=0
6683       n_corr1=0
6684       if (fgProcs.le.1) goto 30
6685       if (lprn) then
6686         write (iout,'(a)') 'Contact function values:'
6687         do i=nnt,nct-2
6688           write (iout,'(2i3,50(1x,i2,f5.2))')
6689      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6690      &    j=1,num_cont_hb(i))
6691         enddo
6692       endif
6693 C Caution! Following code assumes that electrostatic interactions concerning
6694 C a given atom are split among at most two processors!
6695       CorrelType=477
6696       CorrelID=MyID+1
6697       ldone=.false.
6698       do i=1,max_cont
6699         do j=1,max_dim
6700           buffer(i,j)=0.0D0
6701         enddo
6702       enddo
6703       mm=mod(MyRank,2)
6704 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6705       if (mm) 20,20,10
6706    10 continue
6707 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6708       if (MyRank.gt.0) then
6709 C Send correlation contributions to the preceding processor
6710         msglen=msglen1
6711         nn=num_cont_hb(iatel_s)
6712         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6713 cd      write (iout,*) 'The BUFFER array:'
6714 cd      do i=1,nn
6715 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6716 cd      enddo
6717         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6718           msglen=msglen2
6719             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6720 C Clear the contacts of the atom passed to the neighboring processor
6721         nn=num_cont_hb(iatel_s+1)
6722 cd      do i=1,nn
6723 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6724 cd      enddo
6725             num_cont_hb(iatel_s)=0
6726         endif
6727 cd      write (iout,*) 'Processor ',MyID,MyRank,
6728 cd   & ' is sending correlation contribution to processor',MyID-1,
6729 cd   & ' msglen=',msglen
6730 cd      write (*,*) 'Processor ',MyID,MyRank,
6731 cd   & ' is sending correlation contribution to processor',MyID-1,
6732 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6733         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6734 cd      write (iout,*) 'Processor ',MyID,
6735 cd   & ' has sent correlation contribution to processor',MyID-1,
6736 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6737 cd      write (*,*) 'Processor ',MyID,
6738 cd   & ' has sent correlation contribution to processor',MyID-1,
6739 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6740         msglen=msglen1
6741       endif ! (MyRank.gt.0)
6742       if (ldone) goto 30
6743       ldone=.true.
6744    20 continue
6745 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6746       if (MyRank.lt.fgProcs-1) then
6747 C Receive correlation contributions from the next processor
6748         msglen=msglen1
6749         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6750 cd      write (iout,*) 'Processor',MyID,
6751 cd   & ' is receiving correlation contribution from processor',MyID+1,
6752 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6753 cd      write (*,*) 'Processor',MyID,
6754 cd   & ' is receiving correlation contribution from processor',MyID+1,
6755 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6756         nbytes=-1
6757         do while (nbytes.le.0)
6758           call mp_probe(MyID+1,CorrelType,nbytes)
6759         enddo
6760 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6761         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6762 cd      write (iout,*) 'Processor',MyID,
6763 cd   & ' has received correlation contribution from processor',MyID+1,
6764 cd   & ' msglen=',msglen,' nbytes=',nbytes
6765 cd      write (iout,*) 'The received BUFFER array:'
6766 cd      do i=1,max_cont
6767 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6768 cd      enddo
6769         if (msglen.eq.msglen1) then
6770           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6771         else if (msglen.eq.msglen2)  then
6772           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6773           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6774         else
6775           write (iout,*)
6776      & 'ERROR!!!! message length changed while processing correlations.'
6777           write (*,*)
6778      & 'ERROR!!!! message length changed while processing correlations.'
6779           call mp_stopall(Error)
6780         endif ! msglen.eq.msglen1
6781       endif ! MyRank.lt.fgProcs-1
6782       if (ldone) goto 30
6783       ldone=.true.
6784       goto 10
6785    30 continue
6786 #endif
6787       if (lprn) then
6788         write (iout,'(a)') 'Contact function values:'
6789         do i=nnt,nct-2
6790           write (iout,'(2i3,50(1x,i2,f5.2))')
6791      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6792      &    j=1,num_cont_hb(i))
6793         enddo
6794       endif
6795       ecorr=0.0D0
6796       ecorr5=0.0d0
6797       ecorr6=0.0d0
6798 C Remove the loop below after debugging !!!
6799       do i=nnt,nct
6800         do j=1,3
6801           gradcorr(j,i)=0.0D0
6802           gradxorr(j,i)=0.0D0
6803         enddo
6804       enddo
6805 C Calculate the dipole-dipole interaction energies
6806       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6807       do i=iatel_s,iatel_e+1
6808         num_conti=num_cont_hb(i)
6809         do jj=1,num_conti
6810           j=jcont_hb(jj,i)
6811           call dipole(i,j,jj)
6812         enddo
6813       enddo
6814       endif
6815 C Calculate the local-electrostatic correlation terms
6816       do i=iatel_s,iatel_e+1
6817         i1=i+1
6818         num_conti=num_cont_hb(i)
6819         num_conti1=num_cont_hb(i+1)
6820         do jj=1,num_conti
6821           j=jcont_hb(jj,i)
6822           do kk=1,num_conti1
6823             j1=jcont_hb(kk,i1)
6824 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6825 c     &         ' jj=',jj,' kk=',kk
6826             if (j1.eq.j+1 .or. j1.eq.j-1) then
6827 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6828 C The system gains extra energy.
6829               n_corr=n_corr+1
6830               sqd1=dsqrt(d_cont(jj,i))
6831               sqd2=dsqrt(d_cont(kk,i1))
6832               sred_geom = sqd1*sqd2
6833               IF (sred_geom.lt.cutoff_corr) THEN
6834                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6835      &            ekont,fprimcont)
6836 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6837 c     &         ' jj=',jj,' kk=',kk
6838                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6839                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6840                 do l=1,3
6841                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6842                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6843                 enddo
6844                 n_corr1=n_corr1+1
6845 cd               write (iout,*) 'sred_geom=',sred_geom,
6846 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6847                 call calc_eello(i,j,i+1,j1,jj,kk)
6848                 if (wcorr4.gt.0.0d0)
6849      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6850                 if (wcorr5.gt.0.0d0)
6851      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6852 c                print *,"wcorr5",ecorr5
6853 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6854 cd                write(2,*)'ijkl',i,j,i+1,j1
6855                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6856      &               .or. wturn6.eq.0.0d0))then
6857 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6858                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6859 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6860 cd     &            'ecorr6=',ecorr6
6861 cd                write (iout,'(4e15.5)') sred_geom,
6862 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6863 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6864 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6865                 else if (wturn6.gt.0.0d0
6866      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6867 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6868                   eturn6=eturn6+eello_turn6(i,jj,kk)
6869 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6870                 endif
6871               ENDIF
6872 1111          continue
6873             else if (j1.eq.j) then
6874 C Contacts I-J and I-(J+1) occur simultaneously.
6875 C The system loses extra energy.
6876 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6877             endif
6878           enddo ! kk
6879           do kk=1,num_conti
6880             j1=jcont_hb(kk,i)
6881 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6882 c    &         ' jj=',jj,' kk=',kk
6883             if (j1.eq.j+1) then
6884 C Contacts I-J and (I+1)-J occur simultaneously.
6885 C The system loses extra energy.
6886 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6887             endif ! j1==j+1
6888           enddo ! kk
6889         enddo ! jj
6890       enddo ! i
6891       return
6892       end
6893 c------------------------------------------------------------------------------
6894       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6895       implicit real*8 (a-h,o-z)
6896       include 'DIMENSIONS'
6897       include 'COMMON.IOUNITS'
6898       include 'COMMON.DERIV'
6899       include 'COMMON.INTERACT'
6900       include 'COMMON.CONTACTS'
6901       double precision gx(3),gx1(3)
6902       logical lprn
6903       lprn=.false.
6904       eij=facont_hb(jj,i)
6905       ekl=facont_hb(kk,k)
6906       ees0pij=ees0p(jj,i)
6907       ees0pkl=ees0p(kk,k)
6908       ees0mij=ees0m(jj,i)
6909       ees0mkl=ees0m(kk,k)
6910       ekont=eij*ekl
6911       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6912 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6913 C Following 4 lines for diagnostics.
6914 cd    ees0pkl=0.0D0
6915 cd    ees0pij=1.0D0
6916 cd    ees0mkl=0.0D0
6917 cd    ees0mij=1.0D0
6918 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6919 c    &   ' and',k,l
6920 c     write (iout,*)'Contacts have occurred for peptide groups',
6921 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6922 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6923 C Calculate the multi-body contribution to energy.
6924       ecorr=ecorr+ekont*ees
6925       if (calc_grad) then
6926 C Calculate multi-body contributions to the gradient.
6927       do ll=1,3
6928         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6929         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6930      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6931      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6932         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6933      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6934      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6935         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6936         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6937      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6938      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6939         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6940      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6941      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6942       enddo
6943       do m=i+1,j-1
6944         do ll=1,3
6945           gradcorr(ll,m)=gradcorr(ll,m)+
6946      &     ees*ekl*gacont_hbr(ll,jj,i)-
6947      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6948      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6949         enddo
6950       enddo
6951       do m=k+1,l-1
6952         do ll=1,3
6953           gradcorr(ll,m)=gradcorr(ll,m)+
6954      &     ees*eij*gacont_hbr(ll,kk,k)-
6955      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6956      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6957         enddo
6958       enddo
6959       endif
6960       ehbcorr=ekont*ees
6961       return
6962       end
6963 C---------------------------------------------------------------------------
6964       subroutine dipole(i,j,jj)
6965       implicit real*8 (a-h,o-z)
6966       include 'DIMENSIONS'
6967       include 'DIMENSIONS.ZSCOPT'
6968       include 'COMMON.IOUNITS'
6969       include 'COMMON.CHAIN'
6970       include 'COMMON.FFIELD'
6971       include 'COMMON.DERIV'
6972       include 'COMMON.INTERACT'
6973       include 'COMMON.CONTACTS'
6974       include 'COMMON.TORSION'
6975       include 'COMMON.VAR'
6976       include 'COMMON.GEO'
6977       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6978      &  auxmat(2,2)
6979       iti1 = itortyp(itype(i+1))
6980       if (j.lt.nres-1) then
6981         itj1 = itortyp(itype(j+1))
6982       else
6983         itj1=ntortyp+1
6984       endif
6985       do iii=1,2
6986         dipi(iii,1)=Ub2(iii,i)
6987         dipderi(iii)=Ub2der(iii,i)
6988         dipi(iii,2)=b1(iii,iti1)
6989         dipj(iii,1)=Ub2(iii,j)
6990         dipderj(iii)=Ub2der(iii,j)
6991         dipj(iii,2)=b1(iii,itj1)
6992       enddo
6993       kkk=0
6994       do iii=1,2
6995         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6996         do jjj=1,2
6997           kkk=kkk+1
6998           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6999         enddo
7000       enddo
7001       if (.not.calc_grad) return
7002       do kkk=1,5
7003         do lll=1,3
7004           mmm=0
7005           do iii=1,2
7006             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7007      &        auxvec(1))
7008             do jjj=1,2
7009               mmm=mmm+1
7010               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7011             enddo
7012           enddo
7013         enddo
7014       enddo
7015       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7016       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7017       do iii=1,2
7018         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7019       enddo
7020       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7021       do iii=1,2
7022         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7023       enddo
7024       return
7025       end
7026 C---------------------------------------------------------------------------
7027       subroutine calc_eello(i,j,k,l,jj,kk)
7028 C
7029 C This subroutine computes matrices and vectors needed to calculate
7030 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7031 C
7032       implicit real*8 (a-h,o-z)
7033       include 'DIMENSIONS'
7034       include 'DIMENSIONS.ZSCOPT'
7035       include 'COMMON.IOUNITS'
7036       include 'COMMON.CHAIN'
7037       include 'COMMON.DERIV'
7038       include 'COMMON.INTERACT'
7039       include 'COMMON.CONTACTS'
7040       include 'COMMON.TORSION'
7041       include 'COMMON.VAR'
7042       include 'COMMON.GEO'
7043       include 'COMMON.FFIELD'
7044       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7045      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7046       logical lprn
7047       common /kutas/ lprn
7048 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7049 cd     & ' jj=',jj,' kk=',kk
7050 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7051       do iii=1,2
7052         do jjj=1,2
7053           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7054           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7055         enddo
7056       enddo
7057       call transpose2(aa1(1,1),aa1t(1,1))
7058       call transpose2(aa2(1,1),aa2t(1,1))
7059       do kkk=1,5
7060         do lll=1,3
7061           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7062      &      aa1tder(1,1,lll,kkk))
7063           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7064      &      aa2tder(1,1,lll,kkk))
7065         enddo
7066       enddo
7067       if (l.eq.j+1) then
7068 C parallel orientation of the two CA-CA-CA frames.
7069         if (i.gt.1) then
7070           iti=itortyp(itype(i))
7071         else
7072           iti=ntortyp+1
7073         endif
7074         itk1=itortyp(itype(k+1))
7075         itj=itortyp(itype(j))
7076         if (l.lt.nres-1) then
7077           itl1=itortyp(itype(l+1))
7078         else
7079           itl1=ntortyp+1
7080         endif
7081 C A1 kernel(j+1) A2T
7082 cd        do iii=1,2
7083 cd          write (iout,'(3f10.5,5x,3f10.5)')
7084 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7085 cd        enddo
7086         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7087      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7088      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7089 C Following matrices are needed only for 6-th order cumulants
7090         IF (wcorr6.gt.0.0d0) THEN
7091         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7092      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7093      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7094         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7095      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7096      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7097      &   ADtEAderx(1,1,1,1,1,1))
7098         lprn=.false.
7099         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7100      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7101      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7102      &   ADtEA1derx(1,1,1,1,1,1))
7103         ENDIF
7104 C End 6-th order cumulants
7105 cd        lprn=.false.
7106 cd        if (lprn) then
7107 cd        write (2,*) 'In calc_eello6'
7108 cd        do iii=1,2
7109 cd          write (2,*) 'iii=',iii
7110 cd          do kkk=1,5
7111 cd            write (2,*) 'kkk=',kkk
7112 cd            do jjj=1,2
7113 cd              write (2,'(3(2f10.5),5x)')
7114 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7115 cd            enddo
7116 cd          enddo
7117 cd        enddo
7118 cd        endif
7119         call transpose2(EUgder(1,1,k),auxmat(1,1))
7120         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7121         call transpose2(EUg(1,1,k),auxmat(1,1))
7122         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7123         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7124         do iii=1,2
7125           do kkk=1,5
7126             do lll=1,3
7127               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7128      &          EAEAderx(1,1,lll,kkk,iii,1))
7129             enddo
7130           enddo
7131         enddo
7132 C A1T kernel(i+1) A2
7133         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7134      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7135      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7136 C Following matrices are needed only for 6-th order cumulants
7137         IF (wcorr6.gt.0.0d0) THEN
7138         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7139      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7140      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7141         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7142      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7143      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7144      &   ADtEAderx(1,1,1,1,1,2))
7145         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7146      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7147      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7148      &   ADtEA1derx(1,1,1,1,1,2))
7149         ENDIF
7150 C End 6-th order cumulants
7151         call transpose2(EUgder(1,1,l),auxmat(1,1))
7152         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7153         call transpose2(EUg(1,1,l),auxmat(1,1))
7154         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7155         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7156         do iii=1,2
7157           do kkk=1,5
7158             do lll=1,3
7159               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7160      &          EAEAderx(1,1,lll,kkk,iii,2))
7161             enddo
7162           enddo
7163         enddo
7164 C AEAb1 and AEAb2
7165 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7166 C They are needed only when the fifth- or the sixth-order cumulants are
7167 C indluded.
7168         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7169         call transpose2(AEA(1,1,1),auxmat(1,1))
7170         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7171         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7172         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7173         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7174         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7175         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7176         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7177         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7178         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7179         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7180         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7181         call transpose2(AEA(1,1,2),auxmat(1,1))
7182         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7183         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7184         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7185         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7186         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7187         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7188         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7189         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7190         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7191         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7192         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7193 C Calculate the Cartesian derivatives of the vectors.
7194         do iii=1,2
7195           do kkk=1,5
7196             do lll=1,3
7197               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7198               call matvec2(auxmat(1,1),b1(1,iti),
7199      &          AEAb1derx(1,lll,kkk,iii,1,1))
7200               call matvec2(auxmat(1,1),Ub2(1,i),
7201      &          AEAb2derx(1,lll,kkk,iii,1,1))
7202               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7203      &          AEAb1derx(1,lll,kkk,iii,2,1))
7204               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7205      &          AEAb2derx(1,lll,kkk,iii,2,1))
7206               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7207               call matvec2(auxmat(1,1),b1(1,itj),
7208      &          AEAb1derx(1,lll,kkk,iii,1,2))
7209               call matvec2(auxmat(1,1),Ub2(1,j),
7210      &          AEAb2derx(1,lll,kkk,iii,1,2))
7211               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7212      &          AEAb1derx(1,lll,kkk,iii,2,2))
7213               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7214      &          AEAb2derx(1,lll,kkk,iii,2,2))
7215             enddo
7216           enddo
7217         enddo
7218         ENDIF
7219 C End vectors
7220       else
7221 C Antiparallel orientation of the two CA-CA-CA frames.
7222         if (i.gt.1) then
7223           iti=itortyp(itype(i))
7224         else
7225           iti=ntortyp+1
7226         endif
7227         itk1=itortyp(itype(k+1))
7228         itl=itortyp(itype(l))
7229         itj=itortyp(itype(j))
7230         if (j.lt.nres-1) then
7231           itj1=itortyp(itype(j+1))
7232         else
7233           itj1=ntortyp+1
7234         endif
7235 C A2 kernel(j-1)T A1T
7236         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7237      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7238      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7239 C Following matrices are needed only for 6-th order cumulants
7240         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7241      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7242         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7243      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7244      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7245         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7246      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7247      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7248      &   ADtEAderx(1,1,1,1,1,1))
7249         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7250      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7251      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7252      &   ADtEA1derx(1,1,1,1,1,1))
7253         ENDIF
7254 C End 6-th order cumulants
7255         call transpose2(EUgder(1,1,k),auxmat(1,1))
7256         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7257         call transpose2(EUg(1,1,k),auxmat(1,1))
7258         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7259         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7260         do iii=1,2
7261           do kkk=1,5
7262             do lll=1,3
7263               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7264      &          EAEAderx(1,1,lll,kkk,iii,1))
7265             enddo
7266           enddo
7267         enddo
7268 C A2T kernel(i+1)T A1
7269         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7270      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7271      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7272 C Following matrices are needed only for 6-th order cumulants
7273         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7274      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7275         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7276      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7277      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7278         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7279      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7280      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7281      &   ADtEAderx(1,1,1,1,1,2))
7282         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7283      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7284      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7285      &   ADtEA1derx(1,1,1,1,1,2))
7286         ENDIF
7287 C End 6-th order cumulants
7288         call transpose2(EUgder(1,1,j),auxmat(1,1))
7289         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7290         call transpose2(EUg(1,1,j),auxmat(1,1))
7291         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7292         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7293         do iii=1,2
7294           do kkk=1,5
7295             do lll=1,3
7296               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7297      &          EAEAderx(1,1,lll,kkk,iii,2))
7298             enddo
7299           enddo
7300         enddo
7301 C AEAb1 and AEAb2
7302 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7303 C They are needed only when the fifth- or the sixth-order cumulants are
7304 C indluded.
7305         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7306      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7307         call transpose2(AEA(1,1,1),auxmat(1,1))
7308         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7309         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7310         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7311         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7312         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7313         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7314         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7315         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7316         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7317         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7318         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7319         call transpose2(AEA(1,1,2),auxmat(1,1))
7320         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7321         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7322         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7323         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7324         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7325         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7326         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7327         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7328         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7329         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7330         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7331 C Calculate the Cartesian derivatives of the vectors.
7332         do iii=1,2
7333           do kkk=1,5
7334             do lll=1,3
7335               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7336               call matvec2(auxmat(1,1),b1(1,iti),
7337      &          AEAb1derx(1,lll,kkk,iii,1,1))
7338               call matvec2(auxmat(1,1),Ub2(1,i),
7339      &          AEAb2derx(1,lll,kkk,iii,1,1))
7340               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7341      &          AEAb1derx(1,lll,kkk,iii,2,1))
7342               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7343      &          AEAb2derx(1,lll,kkk,iii,2,1))
7344               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7345               call matvec2(auxmat(1,1),b1(1,itl),
7346      &          AEAb1derx(1,lll,kkk,iii,1,2))
7347               call matvec2(auxmat(1,1),Ub2(1,l),
7348      &          AEAb2derx(1,lll,kkk,iii,1,2))
7349               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7350      &          AEAb1derx(1,lll,kkk,iii,2,2))
7351               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7352      &          AEAb2derx(1,lll,kkk,iii,2,2))
7353             enddo
7354           enddo
7355         enddo
7356         ENDIF
7357 C End vectors
7358       endif
7359       return
7360       end
7361 C---------------------------------------------------------------------------
7362       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7363      &  KK,KKderg,AKA,AKAderg,AKAderx)
7364       implicit none
7365       integer nderg
7366       logical transp
7367       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7368      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7369      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7370       integer iii,kkk,lll
7371       integer jjj,mmm
7372       logical lprn
7373       common /kutas/ lprn
7374       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7375       do iii=1,nderg
7376         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7377      &    AKAderg(1,1,iii))
7378       enddo
7379 cd      if (lprn) write (2,*) 'In kernel'
7380       do kkk=1,5
7381 cd        if (lprn) write (2,*) 'kkk=',kkk
7382         do lll=1,3
7383           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7384      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7385 cd          if (lprn) then
7386 cd            write (2,*) 'lll=',lll
7387 cd            write (2,*) 'iii=1'
7388 cd            do jjj=1,2
7389 cd              write (2,'(3(2f10.5),5x)')
7390 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7391 cd            enddo
7392 cd          endif
7393           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7394      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7395 cd          if (lprn) then
7396 cd            write (2,*) 'lll=',lll
7397 cd            write (2,*) 'iii=2'
7398 cd            do jjj=1,2
7399 cd              write (2,'(3(2f10.5),5x)')
7400 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7401 cd            enddo
7402 cd          endif
7403         enddo
7404       enddo
7405       return
7406       end
7407 C---------------------------------------------------------------------------
7408       double precision function eello4(i,j,k,l,jj,kk)
7409       implicit real*8 (a-h,o-z)
7410       include 'DIMENSIONS'
7411       include 'DIMENSIONS.ZSCOPT'
7412       include 'COMMON.IOUNITS'
7413       include 'COMMON.CHAIN'
7414       include 'COMMON.DERIV'
7415       include 'COMMON.INTERACT'
7416       include 'COMMON.CONTACTS'
7417       include 'COMMON.TORSION'
7418       include 'COMMON.VAR'
7419       include 'COMMON.GEO'
7420       double precision pizda(2,2),ggg1(3),ggg2(3)
7421 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7422 cd        eello4=0.0d0
7423 cd        return
7424 cd      endif
7425 cd      print *,'eello4:',i,j,k,l,jj,kk
7426 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7427 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7428 cold      eij=facont_hb(jj,i)
7429 cold      ekl=facont_hb(kk,k)
7430 cold      ekont=eij*ekl
7431       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7432       if (calc_grad) then
7433 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7434       gcorr_loc(k-1)=gcorr_loc(k-1)
7435      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7436       if (l.eq.j+1) then
7437         gcorr_loc(l-1)=gcorr_loc(l-1)
7438      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7439       else
7440         gcorr_loc(j-1)=gcorr_loc(j-1)
7441      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7442       endif
7443       do iii=1,2
7444         do kkk=1,5
7445           do lll=1,3
7446             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7447      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7448 cd            derx(lll,kkk,iii)=0.0d0
7449           enddo
7450         enddo
7451       enddo
7452 cd      gcorr_loc(l-1)=0.0d0
7453 cd      gcorr_loc(j-1)=0.0d0
7454 cd      gcorr_loc(k-1)=0.0d0
7455 cd      eel4=1.0d0
7456 cd      write (iout,*)'Contacts have occurred for peptide groups',
7457 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7458 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7459       if (j.lt.nres-1) then
7460         j1=j+1
7461         j2=j-1
7462       else
7463         j1=j-1
7464         j2=j-2
7465       endif
7466       if (l.lt.nres-1) then
7467         l1=l+1
7468         l2=l-1
7469       else
7470         l1=l-1
7471         l2=l-2
7472       endif
7473       do ll=1,3
7474 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
7475         ggg1(ll)=eel4*g_contij(ll,1)
7476         ggg2(ll)=eel4*g_contij(ll,2)
7477         ghalf=0.5d0*ggg1(ll)
7478 cd        ghalf=0.0d0
7479         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
7480         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7481         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
7482         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7483 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
7484         ghalf=0.5d0*ggg2(ll)
7485 cd        ghalf=0.0d0
7486         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
7487         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7488         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
7489         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7490       enddo
7491 cd      goto 1112
7492       do m=i+1,j-1
7493         do ll=1,3
7494 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
7495           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7496         enddo
7497       enddo
7498       do m=k+1,l-1
7499         do ll=1,3
7500 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
7501           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7502         enddo
7503       enddo
7504 1112  continue
7505       do m=i+2,j2
7506         do ll=1,3
7507           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7508         enddo
7509       enddo
7510       do m=k+2,l2
7511         do ll=1,3
7512           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7513         enddo
7514       enddo
7515 cd      do iii=1,nres-3
7516 cd        write (2,*) iii,gcorr_loc(iii)
7517 cd      enddo
7518       endif
7519       eello4=ekont*eel4
7520 cd      write (2,*) 'ekont',ekont
7521 cd      write (iout,*) 'eello4',ekont*eel4
7522       return
7523       end
7524 C---------------------------------------------------------------------------
7525       double precision function eello5(i,j,k,l,jj,kk)
7526       implicit real*8 (a-h,o-z)
7527       include 'DIMENSIONS'
7528       include 'DIMENSIONS.ZSCOPT'
7529       include 'COMMON.IOUNITS'
7530       include 'COMMON.CHAIN'
7531       include 'COMMON.DERIV'
7532       include 'COMMON.INTERACT'
7533       include 'COMMON.CONTACTS'
7534       include 'COMMON.TORSION'
7535       include 'COMMON.VAR'
7536       include 'COMMON.GEO'
7537       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7538       double precision ggg1(3),ggg2(3)
7539 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7540 C                                                                              C
7541 C                            Parallel chains                                   C
7542 C                                                                              C
7543 C          o             o                   o             o                   C
7544 C         /l\           / \             \   / \           / \   /              C
7545 C        /   \         /   \             \ /   \         /   \ /               C
7546 C       j| o |l1       | o |              o| o |         | o |o                C
7547 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7548 C      \i/   \         /   \ /             /   \         /   \                 C
7549 C       o    k1             o                                                  C
7550 C         (I)          (II)                (III)          (IV)                 C
7551 C                                                                              C
7552 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7553 C                                                                              C
7554 C                            Antiparallel chains                               C
7555 C                                                                              C
7556 C          o             o                   o             o                   C
7557 C         /j\           / \             \   / \           / \   /              C
7558 C        /   \         /   \             \ /   \         /   \ /               C
7559 C      j1| o |l        | o |              o| o |         | o |o                C
7560 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7561 C      \i/   \         /   \ /             /   \         /   \                 C
7562 C       o     k1            o                                                  C
7563 C         (I)          (II)                (III)          (IV)                 C
7564 C                                                                              C
7565 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7566 C                                                                              C
7567 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7568 C                                                                              C
7569 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7570 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7571 cd        eello5=0.0d0
7572 cd        return
7573 cd      endif
7574 cd      write (iout,*)
7575 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7576 cd     &   ' and',k,l
7577       itk=itortyp(itype(k))
7578       itl=itortyp(itype(l))
7579       itj=itortyp(itype(j))
7580       eello5_1=0.0d0
7581       eello5_2=0.0d0
7582       eello5_3=0.0d0
7583       eello5_4=0.0d0
7584 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7585 cd     &   eel5_3_num,eel5_4_num)
7586       do iii=1,2
7587         do kkk=1,5
7588           do lll=1,3
7589             derx(lll,kkk,iii)=0.0d0
7590           enddo
7591         enddo
7592       enddo
7593 cd      eij=facont_hb(jj,i)
7594 cd      ekl=facont_hb(kk,k)
7595 cd      ekont=eij*ekl
7596 cd      write (iout,*)'Contacts have occurred for peptide groups',
7597 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7598 cd      goto 1111
7599 C Contribution from the graph I.
7600 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7601 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7602       call transpose2(EUg(1,1,k),auxmat(1,1))
7603       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7604       vv(1)=pizda(1,1)-pizda(2,2)
7605       vv(2)=pizda(1,2)+pizda(2,1)
7606       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7607      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7608       if (calc_grad) then
7609 C Explicit gradient in virtual-dihedral angles.
7610       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7611      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7612      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7613       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7614       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7615       vv(1)=pizda(1,1)-pizda(2,2)
7616       vv(2)=pizda(1,2)+pizda(2,1)
7617       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7618      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7619      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7620       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7621       vv(1)=pizda(1,1)-pizda(2,2)
7622       vv(2)=pizda(1,2)+pizda(2,1)
7623       if (l.eq.j+1) then
7624         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7625      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7626      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7627       else
7628         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7629      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7630      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7631       endif
7632 C Cartesian gradient
7633       do iii=1,2
7634         do kkk=1,5
7635           do lll=1,3
7636             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7637      &        pizda(1,1))
7638             vv(1)=pizda(1,1)-pizda(2,2)
7639             vv(2)=pizda(1,2)+pizda(2,1)
7640             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7641      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7642      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7643           enddo
7644         enddo
7645       enddo
7646 c      goto 1112
7647       endif
7648 c1111  continue
7649 C Contribution from graph II
7650       call transpose2(EE(1,1,itk),auxmat(1,1))
7651       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7652       vv(1)=pizda(1,1)+pizda(2,2)
7653       vv(2)=pizda(2,1)-pizda(1,2)
7654       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7655      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7656       if (calc_grad) then
7657 C Explicit gradient in virtual-dihedral angles.
7658       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7659      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7660       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7661       vv(1)=pizda(1,1)+pizda(2,2)
7662       vv(2)=pizda(2,1)-pizda(1,2)
7663       if (l.eq.j+1) then
7664         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7665      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7666      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7667       else
7668         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7669      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7670      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7671       endif
7672 C Cartesian gradient
7673       do iii=1,2
7674         do kkk=1,5
7675           do lll=1,3
7676             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7677      &        pizda(1,1))
7678             vv(1)=pizda(1,1)+pizda(2,2)
7679             vv(2)=pizda(2,1)-pizda(1,2)
7680             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7681      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7682      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7683           enddo
7684         enddo
7685       enddo
7686 cd      goto 1112
7687       endif
7688 cd1111  continue
7689       if (l.eq.j+1) then
7690 cd        goto 1110
7691 C Parallel orientation
7692 C Contribution from graph III
7693         call transpose2(EUg(1,1,l),auxmat(1,1))
7694         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7695         vv(1)=pizda(1,1)-pizda(2,2)
7696         vv(2)=pizda(1,2)+pizda(2,1)
7697         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7698      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7699         if (calc_grad) then
7700 C Explicit gradient in virtual-dihedral angles.
7701         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7702      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7703      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7704         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7705         vv(1)=pizda(1,1)-pizda(2,2)
7706         vv(2)=pizda(1,2)+pizda(2,1)
7707         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7708      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7709      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7710         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7711         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7712         vv(1)=pizda(1,1)-pizda(2,2)
7713         vv(2)=pizda(1,2)+pizda(2,1)
7714         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7715      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7716      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7717 C Cartesian gradient
7718         do iii=1,2
7719           do kkk=1,5
7720             do lll=1,3
7721               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7722      &          pizda(1,1))
7723               vv(1)=pizda(1,1)-pizda(2,2)
7724               vv(2)=pizda(1,2)+pizda(2,1)
7725               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7726      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7727      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7728             enddo
7729           enddo
7730         enddo
7731 cd        goto 1112
7732         endif
7733 C Contribution from graph IV
7734 cd1110    continue
7735         call transpose2(EE(1,1,itl),auxmat(1,1))
7736         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7737         vv(1)=pizda(1,1)+pizda(2,2)
7738         vv(2)=pizda(2,1)-pizda(1,2)
7739         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7740      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7741         if (calc_grad) then
7742 C Explicit gradient in virtual-dihedral angles.
7743         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7744      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7745         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7746         vv(1)=pizda(1,1)+pizda(2,2)
7747         vv(2)=pizda(2,1)-pizda(1,2)
7748         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7749      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7750      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7751 C Cartesian gradient
7752         do iii=1,2
7753           do kkk=1,5
7754             do lll=1,3
7755               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7756      &          pizda(1,1))
7757               vv(1)=pizda(1,1)+pizda(2,2)
7758               vv(2)=pizda(2,1)-pizda(1,2)
7759               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7760      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7761      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7762             enddo
7763           enddo
7764         enddo
7765         endif
7766       else
7767 C Antiparallel orientation
7768 C Contribution from graph III
7769 c        goto 1110
7770         call transpose2(EUg(1,1,j),auxmat(1,1))
7771         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7772         vv(1)=pizda(1,1)-pizda(2,2)
7773         vv(2)=pizda(1,2)+pizda(2,1)
7774         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7775      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7776         if (calc_grad) then
7777 C Explicit gradient in virtual-dihedral angles.
7778         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7779      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7780      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7781         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7782         vv(1)=pizda(1,1)-pizda(2,2)
7783         vv(2)=pizda(1,2)+pizda(2,1)
7784         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7785      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7786      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7787         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7788         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7789         vv(1)=pizda(1,1)-pizda(2,2)
7790         vv(2)=pizda(1,2)+pizda(2,1)
7791         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7792      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7793      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7794 C Cartesian gradient
7795         do iii=1,2
7796           do kkk=1,5
7797             do lll=1,3
7798               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7799      &          pizda(1,1))
7800               vv(1)=pizda(1,1)-pizda(2,2)
7801               vv(2)=pizda(1,2)+pizda(2,1)
7802               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7803      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7804      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7805             enddo
7806           enddo
7807         enddo
7808 cd        goto 1112
7809         endif
7810 C Contribution from graph IV
7811 1110    continue
7812         call transpose2(EE(1,1,itj),auxmat(1,1))
7813         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7814         vv(1)=pizda(1,1)+pizda(2,2)
7815         vv(2)=pizda(2,1)-pizda(1,2)
7816         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7817      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7818         if (calc_grad) then
7819 C Explicit gradient in virtual-dihedral angles.
7820         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7821      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7822         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7823         vv(1)=pizda(1,1)+pizda(2,2)
7824         vv(2)=pizda(2,1)-pizda(1,2)
7825         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7826      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7827      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7828 C Cartesian gradient
7829         do iii=1,2
7830           do kkk=1,5
7831             do lll=1,3
7832               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7833      &          pizda(1,1))
7834               vv(1)=pizda(1,1)+pizda(2,2)
7835               vv(2)=pizda(2,1)-pizda(1,2)
7836               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7837      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7838      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7839             enddo
7840           enddo
7841         enddo
7842       endif
7843       endif
7844 1112  continue
7845       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7846 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7847 cd        write (2,*) 'ijkl',i,j,k,l
7848 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7849 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7850 cd      endif
7851 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7852 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7853 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7854 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7855       if (calc_grad) then
7856       if (j.lt.nres-1) then
7857         j1=j+1
7858         j2=j-1
7859       else
7860         j1=j-1
7861         j2=j-2
7862       endif
7863       if (l.lt.nres-1) then
7864         l1=l+1
7865         l2=l-1
7866       else
7867         l1=l-1
7868         l2=l-2
7869       endif
7870 cd      eij=1.0d0
7871 cd      ekl=1.0d0
7872 cd      ekont=1.0d0
7873 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7874       do ll=1,3
7875         ggg1(ll)=eel5*g_contij(ll,1)
7876         ggg2(ll)=eel5*g_contij(ll,2)
7877 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7878         ghalf=0.5d0*ggg1(ll)
7879 cd        ghalf=0.0d0
7880         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7881         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7882         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7883         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7884 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7885         ghalf=0.5d0*ggg2(ll)
7886 cd        ghalf=0.0d0
7887         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7888         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7889         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7890         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7891       enddo
7892 cd      goto 1112
7893       do m=i+1,j-1
7894         do ll=1,3
7895 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7896           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7897         enddo
7898       enddo
7899       do m=k+1,l-1
7900         do ll=1,3
7901 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7902           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7903         enddo
7904       enddo
7905 c1112  continue
7906       do m=i+2,j2
7907         do ll=1,3
7908           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7909         enddo
7910       enddo
7911       do m=k+2,l2
7912         do ll=1,3
7913           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7914         enddo
7915       enddo
7916 cd      do iii=1,nres-3
7917 cd        write (2,*) iii,g_corr5_loc(iii)
7918 cd      enddo
7919       endif
7920       eello5=ekont*eel5
7921 cd      write (2,*) 'ekont',ekont
7922 cd      write (iout,*) 'eello5',ekont*eel5
7923       return
7924       end
7925 c--------------------------------------------------------------------------
7926       double precision function eello6(i,j,k,l,jj,kk)
7927       implicit real*8 (a-h,o-z)
7928       include 'DIMENSIONS'
7929       include 'DIMENSIONS.ZSCOPT'
7930       include 'COMMON.IOUNITS'
7931       include 'COMMON.CHAIN'
7932       include 'COMMON.DERIV'
7933       include 'COMMON.INTERACT'
7934       include 'COMMON.CONTACTS'
7935       include 'COMMON.TORSION'
7936       include 'COMMON.VAR'
7937       include 'COMMON.GEO'
7938       include 'COMMON.FFIELD'
7939       double precision ggg1(3),ggg2(3)
7940 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7941 cd        eello6=0.0d0
7942 cd        return
7943 cd      endif
7944 cd      write (iout,*)
7945 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7946 cd     &   ' and',k,l
7947       eello6_1=0.0d0
7948       eello6_2=0.0d0
7949       eello6_3=0.0d0
7950       eello6_4=0.0d0
7951       eello6_5=0.0d0
7952       eello6_6=0.0d0
7953 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7954 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7955       do iii=1,2
7956         do kkk=1,5
7957           do lll=1,3
7958             derx(lll,kkk,iii)=0.0d0
7959           enddo
7960         enddo
7961       enddo
7962 cd      eij=facont_hb(jj,i)
7963 cd      ekl=facont_hb(kk,k)
7964 cd      ekont=eij*ekl
7965 cd      eij=1.0d0
7966 cd      ekl=1.0d0
7967 cd      ekont=1.0d0
7968       if (l.eq.j+1) then
7969         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7970         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7971         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7972         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7973         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7974         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7975       else
7976         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7977         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7978         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7979         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7980         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7981           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7982         else
7983           eello6_5=0.0d0
7984         endif
7985         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7986       endif
7987 C If turn contributions are considered, they will be handled separately.
7988       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7989 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7990 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7991 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7992 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7993 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7994 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7995 cd      goto 1112
7996       if (calc_grad) then
7997       if (j.lt.nres-1) then
7998         j1=j+1
7999         j2=j-1
8000       else
8001         j1=j-1
8002         j2=j-2
8003       endif
8004       if (l.lt.nres-1) then
8005         l1=l+1
8006         l2=l-1
8007       else
8008         l1=l-1
8009         l2=l-2
8010       endif
8011       do ll=1,3
8012         ggg1(ll)=eel6*g_contij(ll,1)
8013         ggg2(ll)=eel6*g_contij(ll,2)
8014 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8015         ghalf=0.5d0*ggg1(ll)
8016 cd        ghalf=0.0d0
8017         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
8018         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8019         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
8020         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8021         ghalf=0.5d0*ggg2(ll)
8022 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8023 cd        ghalf=0.0d0
8024         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
8025         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8026         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
8027         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8028       enddo
8029 cd      goto 1112
8030       do m=i+1,j-1
8031         do ll=1,3
8032 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8033           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8034         enddo
8035       enddo
8036       do m=k+1,l-1
8037         do ll=1,3
8038 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8039           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8040         enddo
8041       enddo
8042 1112  continue
8043       do m=i+2,j2
8044         do ll=1,3
8045           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8046         enddo
8047       enddo
8048       do m=k+2,l2
8049         do ll=1,3
8050           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8051         enddo
8052       enddo
8053 cd      do iii=1,nres-3
8054 cd        write (2,*) iii,g_corr6_loc(iii)
8055 cd      enddo
8056       endif
8057       eello6=ekont*eel6
8058 cd      write (2,*) 'ekont',ekont
8059 cd      write (iout,*) 'eello6',ekont*eel6
8060       return
8061       end
8062 c--------------------------------------------------------------------------
8063       double precision function eello6_graph1(i,j,k,l,imat,swap)
8064       implicit real*8 (a-h,o-z)
8065       include 'DIMENSIONS'
8066       include 'DIMENSIONS.ZSCOPT'
8067       include 'COMMON.IOUNITS'
8068       include 'COMMON.CHAIN'
8069       include 'COMMON.DERIV'
8070       include 'COMMON.INTERACT'
8071       include 'COMMON.CONTACTS'
8072       include 'COMMON.TORSION'
8073       include 'COMMON.VAR'
8074       include 'COMMON.GEO'
8075       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8076       logical swap
8077       logical lprn
8078       common /kutas/ lprn
8079 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8080 C                                                                              C
8081 C      Parallel       Antiparallel                                             C
8082 C                                                                              C
8083 C          o             o                                                     C
8084 C         /l\           /j\                                                    C
8085 C        /   \         /   \                                                   C
8086 C       /| o |         | o |\                                                  C
8087 C     \ j|/k\|  /   \  |/k\|l /                                                C
8088 C      \ /   \ /     \ /   \ /                                                 C
8089 C       o     o       o     o                                                  C
8090 C       i             i                                                        C
8091 C                                                                              C
8092 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8093       itk=itortyp(itype(k))
8094       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8095       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8096       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8097       call transpose2(EUgC(1,1,k),auxmat(1,1))
8098       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8099       vv1(1)=pizda1(1,1)-pizda1(2,2)
8100       vv1(2)=pizda1(1,2)+pizda1(2,1)
8101       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8102       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8103       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8104       s5=scalar2(vv(1),Dtobr2(1,i))
8105 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8106       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8107       if (.not. calc_grad) return
8108       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8109      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8110      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8111      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8112      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8113      & +scalar2(vv(1),Dtobr2der(1,i)))
8114       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8115       vv1(1)=pizda1(1,1)-pizda1(2,2)
8116       vv1(2)=pizda1(1,2)+pizda1(2,1)
8117       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8118       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8119       if (l.eq.j+1) then
8120         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8121      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8122      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8123      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8124      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8125       else
8126         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8127      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8128      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8129      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8130      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8131       endif
8132       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8133       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8134       vv1(1)=pizda1(1,1)-pizda1(2,2)
8135       vv1(2)=pizda1(1,2)+pizda1(2,1)
8136       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8137      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8138      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8139      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8140       do iii=1,2
8141         if (swap) then
8142           ind=3-iii
8143         else
8144           ind=iii
8145         endif
8146         do kkk=1,5
8147           do lll=1,3
8148             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8149             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8150             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8151             call transpose2(EUgC(1,1,k),auxmat(1,1))
8152             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8153      &        pizda1(1,1))
8154             vv1(1)=pizda1(1,1)-pizda1(2,2)
8155             vv1(2)=pizda1(1,2)+pizda1(2,1)
8156             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8157             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8158      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8159             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8160      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8161             s5=scalar2(vv(1),Dtobr2(1,i))
8162             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8163           enddo
8164         enddo
8165       enddo
8166       return
8167       end
8168 c----------------------------------------------------------------------------
8169       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8170       implicit real*8 (a-h,o-z)
8171       include 'DIMENSIONS'
8172       include 'DIMENSIONS.ZSCOPT'
8173       include 'COMMON.IOUNITS'
8174       include 'COMMON.CHAIN'
8175       include 'COMMON.DERIV'
8176       include 'COMMON.INTERACT'
8177       include 'COMMON.CONTACTS'
8178       include 'COMMON.TORSION'
8179       include 'COMMON.VAR'
8180       include 'COMMON.GEO'
8181       logical swap
8182       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8183      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8184       logical lprn
8185       common /kutas/ lprn
8186 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8187 C                                                                              C
8188 C      Parallel       Antiparallel                                             C
8189 C                                                                              C
8190 C          o             o                                                     C
8191 C     \   /l\           /j\   /                                                C
8192 C      \ /   \         /   \ /                                                 C
8193 C       o| o |         | o |o                                                  C
8194 C     \ j|/k\|      \  |/k\|l                                                  C
8195 C      \ /   \       \ /   \                                                   C
8196 C       o             o                                                        C
8197 C       i             i                                                        C
8198 C                                                                              C
8199 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8200 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8201 C AL 7/4/01 s1 would occur in the sixth-order moment,
8202 C           but not in a cluster cumulant
8203 #ifdef MOMENT
8204       s1=dip(1,jj,i)*dip(1,kk,k)
8205 #endif
8206       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8207       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8208       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8209       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8210       call transpose2(EUg(1,1,k),auxmat(1,1))
8211       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8212       vv(1)=pizda(1,1)-pizda(2,2)
8213       vv(2)=pizda(1,2)+pizda(2,1)
8214       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8215 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8216 #ifdef MOMENT
8217       eello6_graph2=-(s1+s2+s3+s4)
8218 #else
8219       eello6_graph2=-(s2+s3+s4)
8220 #endif
8221 c      eello6_graph2=-s3
8222       if (.not. calc_grad) return
8223 C Derivatives in gamma(i-1)
8224       if (i.gt.1) then
8225 #ifdef MOMENT
8226         s1=dipderg(1,jj,i)*dip(1,kk,k)
8227 #endif
8228         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8229         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8230         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8231         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8232 #ifdef MOMENT
8233         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8234 #else
8235         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8236 #endif
8237 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8238       endif
8239 C Derivatives in gamma(k-1)
8240 #ifdef MOMENT
8241       s1=dip(1,jj,i)*dipderg(1,kk,k)
8242 #endif
8243       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8244       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8245       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8246       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8247       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8248       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8249       vv(1)=pizda(1,1)-pizda(2,2)
8250       vv(2)=pizda(1,2)+pizda(2,1)
8251       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8252 #ifdef MOMENT
8253       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8254 #else
8255       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8256 #endif
8257 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8258 C Derivatives in gamma(j-1) or gamma(l-1)
8259       if (j.gt.1) then
8260 #ifdef MOMENT
8261         s1=dipderg(3,jj,i)*dip(1,kk,k)
8262 #endif
8263         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8264         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8265         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8266         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8267         vv(1)=pizda(1,1)-pizda(2,2)
8268         vv(2)=pizda(1,2)+pizda(2,1)
8269         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8270 #ifdef MOMENT
8271         if (swap) then
8272           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8273         else
8274           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8275         endif
8276 #endif
8277         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8278 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8279       endif
8280 C Derivatives in gamma(l-1) or gamma(j-1)
8281       if (l.gt.1) then
8282 #ifdef MOMENT
8283         s1=dip(1,jj,i)*dipderg(3,kk,k)
8284 #endif
8285         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8286         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8287         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8288         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8289         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8290         vv(1)=pizda(1,1)-pizda(2,2)
8291         vv(2)=pizda(1,2)+pizda(2,1)
8292         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8293 #ifdef MOMENT
8294         if (swap) then
8295           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8296         else
8297           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8298         endif
8299 #endif
8300         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8301 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8302       endif
8303 C Cartesian derivatives.
8304       if (lprn) then
8305         write (2,*) 'In eello6_graph2'
8306         do iii=1,2
8307           write (2,*) 'iii=',iii
8308           do kkk=1,5
8309             write (2,*) 'kkk=',kkk
8310             do jjj=1,2
8311               write (2,'(3(2f10.5),5x)')
8312      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8313             enddo
8314           enddo
8315         enddo
8316       endif
8317       do iii=1,2
8318         do kkk=1,5
8319           do lll=1,3
8320 #ifdef MOMENT
8321             if (iii.eq.1) then
8322               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8323             else
8324               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8325             endif
8326 #endif
8327             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8328      &        auxvec(1))
8329             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8330             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8331      &        auxvec(1))
8332             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8333             call transpose2(EUg(1,1,k),auxmat(1,1))
8334             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8335      &        pizda(1,1))
8336             vv(1)=pizda(1,1)-pizda(2,2)
8337             vv(2)=pizda(1,2)+pizda(2,1)
8338             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8339 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8340 #ifdef MOMENT
8341             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8342 #else
8343             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8344 #endif
8345             if (swap) then
8346               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8347             else
8348               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8349             endif
8350           enddo
8351         enddo
8352       enddo
8353       return
8354       end
8355 c----------------------------------------------------------------------------
8356       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8357       implicit real*8 (a-h,o-z)
8358       include 'DIMENSIONS'
8359       include 'DIMENSIONS.ZSCOPT'
8360       include 'COMMON.IOUNITS'
8361       include 'COMMON.CHAIN'
8362       include 'COMMON.DERIV'
8363       include 'COMMON.INTERACT'
8364       include 'COMMON.CONTACTS'
8365       include 'COMMON.TORSION'
8366       include 'COMMON.VAR'
8367       include 'COMMON.GEO'
8368       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8369       logical swap
8370 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8371 C                                                                              C
8372 C      Parallel       Antiparallel                                             C
8373 C                                                                              C
8374 C          o             o                                                     C
8375 C         /l\   /   \   /j\                                                    C
8376 C        /   \ /     \ /   \                                                   C
8377 C       /| o |o       o| o |\                                                  C
8378 C       j|/k\|  /      |/k\|l /                                                C
8379 C        /   \ /       /   \ /                                                 C
8380 C       /     o       /     o                                                  C
8381 C       i             i                                                        C
8382 C                                                                              C
8383 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8384 C
8385 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8386 C           energy moment and not to the cluster cumulant.
8387       iti=itortyp(itype(i))
8388       if (j.lt.nres-1) then
8389         itj1=itortyp(itype(j+1))
8390       else
8391         itj1=ntortyp+1
8392       endif
8393       itk=itortyp(itype(k))
8394       itk1=itortyp(itype(k+1))
8395       if (l.lt.nres-1) then
8396         itl1=itortyp(itype(l+1))
8397       else
8398         itl1=ntortyp+1
8399       endif
8400 #ifdef MOMENT
8401       s1=dip(4,jj,i)*dip(4,kk,k)
8402 #endif
8403       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8404       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8405       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8406       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8407       call transpose2(EE(1,1,itk),auxmat(1,1))
8408       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8409       vv(1)=pizda(1,1)+pizda(2,2)
8410       vv(2)=pizda(2,1)-pizda(1,2)
8411       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8412 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8413 #ifdef MOMENT
8414       eello6_graph3=-(s1+s2+s3+s4)
8415 #else
8416       eello6_graph3=-(s2+s3+s4)
8417 #endif
8418 c      eello6_graph3=-s4
8419       if (.not. calc_grad) return
8420 C Derivatives in gamma(k-1)
8421       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8422       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8423       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8424       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8425 C Derivatives in gamma(l-1)
8426       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8427       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8428       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8429       vv(1)=pizda(1,1)+pizda(2,2)
8430       vv(2)=pizda(2,1)-pizda(1,2)
8431       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8432       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8433 C Cartesian derivatives.
8434       do iii=1,2
8435         do kkk=1,5
8436           do lll=1,3
8437 #ifdef MOMENT
8438             if (iii.eq.1) then
8439               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8440             else
8441               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8442             endif
8443 #endif
8444             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8445      &        auxvec(1))
8446             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8447             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8448      &        auxvec(1))
8449             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8450             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8451      &        pizda(1,1))
8452             vv(1)=pizda(1,1)+pizda(2,2)
8453             vv(2)=pizda(2,1)-pizda(1,2)
8454             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8455 #ifdef MOMENT
8456             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8457 #else
8458             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8459 #endif
8460             if (swap) then
8461               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8462             else
8463               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8464             endif
8465 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8466           enddo
8467         enddo
8468       enddo
8469       return
8470       end
8471 c----------------------------------------------------------------------------
8472       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8473       implicit real*8 (a-h,o-z)
8474       include 'DIMENSIONS'
8475       include 'DIMENSIONS.ZSCOPT'
8476       include 'COMMON.IOUNITS'
8477       include 'COMMON.CHAIN'
8478       include 'COMMON.DERIV'
8479       include 'COMMON.INTERACT'
8480       include 'COMMON.CONTACTS'
8481       include 'COMMON.TORSION'
8482       include 'COMMON.VAR'
8483       include 'COMMON.GEO'
8484       include 'COMMON.FFIELD'
8485       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8486      & auxvec1(2),auxmat1(2,2)
8487       logical swap
8488 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8489 C                                                                              C
8490 C      Parallel       Antiparallel                                             C
8491 C                                                                              C
8492 C          o             o                                                     C
8493 C         /l\   /   \   /j\                                                    C
8494 C        /   \ /     \ /   \                                                   C
8495 C       /| o |o       o| o |\                                                  C
8496 C     \ j|/k\|      \  |/k\|l                                                  C
8497 C      \ /   \       \ /   \                                                   C
8498 C       o     \       o     \                                                  C
8499 C       i             i                                                        C
8500 C                                                                              C
8501 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8502 C
8503 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8504 C           energy moment and not to the cluster cumulant.
8505 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8506       iti=itortyp(itype(i))
8507       itj=itortyp(itype(j))
8508       if (j.lt.nres-1) then
8509         itj1=itortyp(itype(j+1))
8510       else
8511         itj1=ntortyp+1
8512       endif
8513       itk=itortyp(itype(k))
8514       if (k.lt.nres-1) then
8515         itk1=itortyp(itype(k+1))
8516       else
8517         itk1=ntortyp+1
8518       endif
8519       itl=itortyp(itype(l))
8520       if (l.lt.nres-1) then
8521         itl1=itortyp(itype(l+1))
8522       else
8523         itl1=ntortyp+1
8524       endif
8525 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8526 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8527 cd     & ' itl',itl,' itl1',itl1
8528 #ifdef MOMENT
8529       if (imat.eq.1) then
8530         s1=dip(3,jj,i)*dip(3,kk,k)
8531       else
8532         s1=dip(2,jj,j)*dip(2,kk,l)
8533       endif
8534 #endif
8535       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8536       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8537       if (j.eq.l+1) then
8538         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8539         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8540       else
8541         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8542         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8543       endif
8544       call transpose2(EUg(1,1,k),auxmat(1,1))
8545       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8546       vv(1)=pizda(1,1)-pizda(2,2)
8547       vv(2)=pizda(2,1)+pizda(1,2)
8548       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8549 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8550 #ifdef MOMENT
8551       eello6_graph4=-(s1+s2+s3+s4)
8552 #else
8553       eello6_graph4=-(s2+s3+s4)
8554 #endif
8555       if (.not. calc_grad) return
8556 C Derivatives in gamma(i-1)
8557       if (i.gt.1) then
8558 #ifdef MOMENT
8559         if (imat.eq.1) then
8560           s1=dipderg(2,jj,i)*dip(3,kk,k)
8561         else
8562           s1=dipderg(4,jj,j)*dip(2,kk,l)
8563         endif
8564 #endif
8565         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8566         if (j.eq.l+1) then
8567           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8568           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8569         else
8570           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8571           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8572         endif
8573         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8574         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8575 cd          write (2,*) 'turn6 derivatives'
8576 #ifdef MOMENT
8577           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8578 #else
8579           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8580 #endif
8581         else
8582 #ifdef MOMENT
8583           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8584 #else
8585           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8586 #endif
8587         endif
8588       endif
8589 C Derivatives in gamma(k-1)
8590 #ifdef MOMENT
8591       if (imat.eq.1) then
8592         s1=dip(3,jj,i)*dipderg(2,kk,k)
8593       else
8594         s1=dip(2,jj,j)*dipderg(4,kk,l)
8595       endif
8596 #endif
8597       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8598       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8599       if (j.eq.l+1) then
8600         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8601         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8602       else
8603         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8604         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8605       endif
8606       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8607       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8608       vv(1)=pizda(1,1)-pizda(2,2)
8609       vv(2)=pizda(2,1)+pizda(1,2)
8610       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8611       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8612 #ifdef MOMENT
8613         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8614 #else
8615         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8616 #endif
8617       else
8618 #ifdef MOMENT
8619         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8620 #else
8621         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8622 #endif
8623       endif
8624 C Derivatives in gamma(j-1) or gamma(l-1)
8625       if (l.eq.j+1 .and. l.gt.1) then
8626         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8627         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8628         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8629         vv(1)=pizda(1,1)-pizda(2,2)
8630         vv(2)=pizda(2,1)+pizda(1,2)
8631         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8632         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8633       else if (j.gt.1) then
8634         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8635         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8636         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8637         vv(1)=pizda(1,1)-pizda(2,2)
8638         vv(2)=pizda(2,1)+pizda(1,2)
8639         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8640         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8641           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8642         else
8643           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8644         endif
8645       endif
8646 C Cartesian derivatives.
8647       do iii=1,2
8648         do kkk=1,5
8649           do lll=1,3
8650 #ifdef MOMENT
8651             if (iii.eq.1) then
8652               if (imat.eq.1) then
8653                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8654               else
8655                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8656               endif
8657             else
8658               if (imat.eq.1) then
8659                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8660               else
8661                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8662               endif
8663             endif
8664 #endif
8665             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8666      &        auxvec(1))
8667             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8668             if (j.eq.l+1) then
8669               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8670      &          b1(1,itj1),auxvec(1))
8671               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8672             else
8673               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8674      &          b1(1,itl1),auxvec(1))
8675               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8676             endif
8677             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8678      &        pizda(1,1))
8679             vv(1)=pizda(1,1)-pizda(2,2)
8680             vv(2)=pizda(2,1)+pizda(1,2)
8681             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8682             if (swap) then
8683               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8684 #ifdef MOMENT
8685                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8686      &             -(s1+s2+s4)
8687 #else
8688                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8689      &             -(s2+s4)
8690 #endif
8691                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8692               else
8693 #ifdef MOMENT
8694                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8695 #else
8696                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8697 #endif
8698                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8699               endif
8700             else
8701 #ifdef MOMENT
8702               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8703 #else
8704               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8705 #endif
8706               if (l.eq.j+1) then
8707                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8708               else
8709                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8710               endif
8711             endif
8712           enddo
8713         enddo
8714       enddo
8715       return
8716       end
8717 c----------------------------------------------------------------------------
8718       double precision function eello_turn6(i,jj,kk)
8719       implicit real*8 (a-h,o-z)
8720       include 'DIMENSIONS'
8721       include 'DIMENSIONS.ZSCOPT'
8722       include 'COMMON.IOUNITS'
8723       include 'COMMON.CHAIN'
8724       include 'COMMON.DERIV'
8725       include 'COMMON.INTERACT'
8726       include 'COMMON.CONTACTS'
8727       include 'COMMON.TORSION'
8728       include 'COMMON.VAR'
8729       include 'COMMON.GEO'
8730       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8731      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8732      &  ggg1(3),ggg2(3)
8733       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8734      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8735 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8736 C           the respective energy moment and not to the cluster cumulant.
8737       eello_turn6=0.0d0
8738       j=i+4
8739       k=i+1
8740       l=i+3
8741       iti=itortyp(itype(i))
8742       itk=itortyp(itype(k))
8743       itk1=itortyp(itype(k+1))
8744       itl=itortyp(itype(l))
8745       itj=itortyp(itype(j))
8746 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8747 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8748 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8749 cd        eello6=0.0d0
8750 cd        return
8751 cd      endif
8752 cd      write (iout,*)
8753 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8754 cd     &   ' and',k,l
8755 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8756       do iii=1,2
8757         do kkk=1,5
8758           do lll=1,3
8759             derx_turn(lll,kkk,iii)=0.0d0
8760           enddo
8761         enddo
8762       enddo
8763 cd      eij=1.0d0
8764 cd      ekl=1.0d0
8765 cd      ekont=1.0d0
8766       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8767 cd      eello6_5=0.0d0
8768 cd      write (2,*) 'eello6_5',eello6_5
8769 #ifdef MOMENT
8770       call transpose2(AEA(1,1,1),auxmat(1,1))
8771       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8772       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8773       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8774 #else
8775       s1 = 0.0d0
8776 #endif
8777       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8778       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8779       s2 = scalar2(b1(1,itk),vtemp1(1))
8780 #ifdef MOMENT
8781       call transpose2(AEA(1,1,2),atemp(1,1))
8782       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8783       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8784       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8785 #else
8786       s8=0.0d0
8787 #endif
8788       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8789       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8790       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8791 #ifdef MOMENT
8792       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8793       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8794       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8795       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8796       ss13 = scalar2(b1(1,itk),vtemp4(1))
8797       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8798 #else
8799       s13=0.0d0
8800 #endif
8801 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8802 c      s1=0.0d0
8803 c      s2=0.0d0
8804 c      s8=0.0d0
8805 c      s12=0.0d0
8806 c      s13=0.0d0
8807       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8808       if (calc_grad) then
8809 C Derivatives in gamma(i+2)
8810 #ifdef MOMENT
8811       call transpose2(AEA(1,1,1),auxmatd(1,1))
8812       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8813       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8814       call transpose2(AEAderg(1,1,2),atempd(1,1))
8815       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8816       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8817 #else
8818       s8d=0.0d0
8819 #endif
8820       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8821       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8822       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8823 c      s1d=0.0d0
8824 c      s2d=0.0d0
8825 c      s8d=0.0d0
8826 c      s12d=0.0d0
8827 c      s13d=0.0d0
8828       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8829 C Derivatives in gamma(i+3)
8830 #ifdef MOMENT
8831       call transpose2(AEA(1,1,1),auxmatd(1,1))
8832       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8833       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8834       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8835 #else
8836       s1d=0.0d0
8837 #endif
8838       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8839       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8840       s2d = scalar2(b1(1,itk),vtemp1d(1))
8841 #ifdef MOMENT
8842       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8843       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8844 #endif
8845       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8846 #ifdef MOMENT
8847       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8848       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8849       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8850 #else
8851       s13d=0.0d0
8852 #endif
8853 c      s1d=0.0d0
8854 c      s2d=0.0d0
8855 c      s8d=0.0d0
8856 c      s12d=0.0d0
8857 c      s13d=0.0d0
8858 #ifdef MOMENT
8859       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8860      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8861 #else
8862       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8863      &               -0.5d0*ekont*(s2d+s12d)
8864 #endif
8865 C Derivatives in gamma(i+4)
8866       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8867       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8868       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8869 #ifdef MOMENT
8870       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8871       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8872       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8873 #else
8874       s13d = 0.0d0
8875 #endif
8876 c      s1d=0.0d0
8877 c      s2d=0.0d0
8878 c      s8d=0.0d0
8879 C      s12d=0.0d0
8880 c      s13d=0.0d0
8881 #ifdef MOMENT
8882       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8883 #else
8884       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8885 #endif
8886 C Derivatives in gamma(i+5)
8887 #ifdef MOMENT
8888       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8889       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8890       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8891 #else
8892       s1d = 0.0d0
8893 #endif
8894       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8895       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8896       s2d = scalar2(b1(1,itk),vtemp1d(1))
8897 #ifdef MOMENT
8898       call transpose2(AEA(1,1,2),atempd(1,1))
8899       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8900       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8901 #else
8902       s8d = 0.0d0
8903 #endif
8904       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8905       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8906 #ifdef MOMENT
8907       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8908       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8909       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8910 #else
8911       s13d = 0.0d0
8912 #endif
8913 c      s1d=0.0d0
8914 c      s2d=0.0d0
8915 c      s8d=0.0d0
8916 c      s12d=0.0d0
8917 c      s13d=0.0d0
8918 #ifdef MOMENT
8919       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8920      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8921 #else
8922       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8923      &               -0.5d0*ekont*(s2d+s12d)
8924 #endif
8925 C Cartesian derivatives
8926       do iii=1,2
8927         do kkk=1,5
8928           do lll=1,3
8929 #ifdef MOMENT
8930             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8931             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8932             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8933 #else
8934             s1d = 0.0d0
8935 #endif
8936             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8937             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8938      &          vtemp1d(1))
8939             s2d = scalar2(b1(1,itk),vtemp1d(1))
8940 #ifdef MOMENT
8941             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8942             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8943             s8d = -(atempd(1,1)+atempd(2,2))*
8944      &           scalar2(cc(1,1,itl),vtemp2(1))
8945 #else
8946             s8d = 0.0d0
8947 #endif
8948             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8949      &           auxmatd(1,1))
8950             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8951             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8952 c      s1d=0.0d0
8953 c      s2d=0.0d0
8954 c      s8d=0.0d0
8955 c      s12d=0.0d0
8956 c      s13d=0.0d0
8957 #ifdef MOMENT
8958             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8959      &        - 0.5d0*(s1d+s2d)
8960 #else
8961             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8962      &        - 0.5d0*s2d
8963 #endif
8964 #ifdef MOMENT
8965             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8966      &        - 0.5d0*(s8d+s12d)
8967 #else
8968             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8969      &        - 0.5d0*s12d
8970 #endif
8971           enddo
8972         enddo
8973       enddo
8974 #ifdef MOMENT
8975       do kkk=1,5
8976         do lll=1,3
8977           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8978      &      achuj_tempd(1,1))
8979           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8980           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8981           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8982           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8983           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8984      &      vtemp4d(1))
8985           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8986           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8987           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8988         enddo
8989       enddo
8990 #endif
8991 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8992 cd     &  16*eel_turn6_num
8993 cd      goto 1112
8994       if (j.lt.nres-1) then
8995         j1=j+1
8996         j2=j-1
8997       else
8998         j1=j-1
8999         j2=j-2
9000       endif
9001       if (l.lt.nres-1) then
9002         l1=l+1
9003         l2=l-1
9004       else
9005         l1=l-1
9006         l2=l-2
9007       endif
9008       do ll=1,3
9009         ggg1(ll)=eel_turn6*g_contij(ll,1)
9010         ggg2(ll)=eel_turn6*g_contij(ll,2)
9011         ghalf=0.5d0*ggg1(ll)
9012 cd        ghalf=0.0d0
9013         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
9014      &    +ekont*derx_turn(ll,2,1)
9015         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9016         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
9017      &    +ekont*derx_turn(ll,4,1)
9018         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9019         ghalf=0.5d0*ggg2(ll)
9020 cd        ghalf=0.0d0
9021         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
9022      &    +ekont*derx_turn(ll,2,2)
9023         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9024         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
9025      &    +ekont*derx_turn(ll,4,2)
9026         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9027       enddo
9028 cd      goto 1112
9029       do m=i+1,j-1
9030         do ll=1,3
9031           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9032         enddo
9033       enddo
9034       do m=k+1,l-1
9035         do ll=1,3
9036           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9037         enddo
9038       enddo
9039 1112  continue
9040       do m=i+2,j2
9041         do ll=1,3
9042           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9043         enddo
9044       enddo
9045       do m=k+2,l2
9046         do ll=1,3
9047           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9048         enddo
9049       enddo
9050 cd      do iii=1,nres-3
9051 cd        write (2,*) iii,g_corr6_loc(iii)
9052 cd      enddo
9053       endif
9054       eello_turn6=ekont*eel_turn6
9055 cd      write (2,*) 'ekont',ekont
9056 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9057       return
9058       end
9059 crc-------------------------------------------------
9060       SUBROUTINE MATVEC2(A1,V1,V2)
9061       implicit real*8 (a-h,o-z)
9062       include 'DIMENSIONS'
9063       DIMENSION A1(2,2),V1(2),V2(2)
9064 c      DO 1 I=1,2
9065 c        VI=0.0
9066 c        DO 3 K=1,2
9067 c    3     VI=VI+A1(I,K)*V1(K)
9068 c        Vaux(I)=VI
9069 c    1 CONTINUE
9070
9071       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9072       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9073
9074       v2(1)=vaux1
9075       v2(2)=vaux2
9076       END
9077 C---------------------------------------
9078       SUBROUTINE MATMAT2(A1,A2,A3)
9079       implicit real*8 (a-h,o-z)
9080       include 'DIMENSIONS'
9081       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9082 c      DIMENSION AI3(2,2)
9083 c        DO  J=1,2
9084 c          A3IJ=0.0
9085 c          DO K=1,2
9086 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9087 c          enddo
9088 c          A3(I,J)=A3IJ
9089 c       enddo
9090 c      enddo
9091
9092       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9093       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9094       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9095       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9096
9097       A3(1,1)=AI3_11
9098       A3(2,1)=AI3_21
9099       A3(1,2)=AI3_12
9100       A3(2,2)=AI3_22
9101       END
9102
9103 c-------------------------------------------------------------------------
9104       double precision function scalar2(u,v)
9105       implicit none
9106       double precision u(2),v(2)
9107       double precision sc
9108       integer i
9109       scalar2=u(1)*v(1)+u(2)*v(2)
9110       return
9111       end
9112
9113 C-----------------------------------------------------------------------------
9114
9115       subroutine transpose2(a,at)
9116       implicit none
9117       double precision a(2,2),at(2,2)
9118       at(1,1)=a(1,1)
9119       at(1,2)=a(2,1)
9120       at(2,1)=a(1,2)
9121       at(2,2)=a(2,2)
9122       return
9123       end
9124 c--------------------------------------------------------------------------
9125       subroutine transpose(n,a,at)
9126       implicit none
9127       integer n,i,j
9128       double precision a(n,n),at(n,n)
9129       do i=1,n
9130         do j=1,n
9131           at(j,i)=a(i,j)
9132         enddo
9133       enddo
9134       return
9135       end
9136 C---------------------------------------------------------------------------
9137       subroutine prodmat3(a1,a2,kk,transp,prod)
9138       implicit none
9139       integer i,j
9140       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9141       logical transp
9142 crc      double precision auxmat(2,2),prod_(2,2)
9143
9144       if (transp) then
9145 crc        call transpose2(kk(1,1),auxmat(1,1))
9146 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9147 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9148
9149            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9150      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9151            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9152      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9153            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9154      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9155            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9156      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9157
9158       else
9159 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9160 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9161
9162            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9163      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9164            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9165      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9166            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9167      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9168            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9169      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9170
9171       endif
9172 c      call transpose2(a2(1,1),a2t(1,1))
9173
9174 crc      print *,transp
9175 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9176 crc      print *,((prod(i,j),i=1,2),j=1,2)
9177
9178       return
9179       end
9180 C-----------------------------------------------------------------------------
9181       double precision function scalar(u,v)
9182       implicit none
9183       double precision u(3),v(3)
9184       double precision sc
9185       integer i
9186       sc=0.0d0
9187       do i=1,3
9188         sc=sc+u(i)*v(i)
9189       enddo
9190       scalar=sc
9191       return
9192       end
9193