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 c      lprn=.false.
6260       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         esccori=0.0d0
6293         do j=1,nterm_sccor(isccori,isccori1)
6294           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6295           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6296           cosphi=dcos(j*tauangle(intertyp,i))
6297           sinphi=dsin(j*tauangle(intertyp,i))
6298           esccori=esccori+v1ij*cosphi+v2ij*sinphi
6299           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6300         enddo
6301         esccor=esccor+esccori
6302         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6303 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6304 c     &gloc_sc(intertyp,i-3,icg)
6305         if (lprn) then
6306         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6307      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6308      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6309      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6310         write (iout,*) "esccori",esccori
6311         call flush(iout)
6312         endif
6313         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6314        enddo !intertyp
6315       enddo
6316 c        do i=1,nres
6317 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6318 c        enddo
6319       return
6320       end
6321 c------------------------------------------------------------------------------
6322       subroutine multibody(ecorr)
6323 C This subroutine calculates multi-body contributions to energy following
6324 C the idea of Skolnick et al. If side chains I and J make a contact and
6325 C at the same time side chains I+1 and J+1 make a contact, an extra
6326 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6327       implicit real*8 (a-h,o-z)
6328       include 'DIMENSIONS'
6329       include 'COMMON.IOUNITS'
6330       include 'COMMON.DERIV'
6331       include 'COMMON.INTERACT'
6332       include 'COMMON.CONTACTS'
6333       double precision gx(3),gx1(3)
6334       logical lprn
6335
6336 C Set lprn=.true. for debugging
6337       lprn=.false.
6338
6339       if (lprn) then
6340         write (iout,'(a)') 'Contact function values:'
6341         do i=nnt,nct-2
6342           write (iout,'(i2,20(1x,i2,f10.5))')
6343      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6344         enddo
6345       endif
6346       ecorr=0.0D0
6347       do i=nnt,nct
6348         do j=1,3
6349           gradcorr(j,i)=0.0D0
6350           gradxorr(j,i)=0.0D0
6351         enddo
6352       enddo
6353       do i=nnt,nct-2
6354
6355         DO ISHIFT = 3,4
6356
6357         i1=i+ishift
6358         num_conti=num_cont(i)
6359         num_conti1=num_cont(i1)
6360         do jj=1,num_conti
6361           j=jcont(jj,i)
6362           do kk=1,num_conti1
6363             j1=jcont(kk,i1)
6364             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6365 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6366 cd   &                   ' ishift=',ishift
6367 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6368 C The system gains extra energy.
6369               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6370             endif   ! j1==j+-ishift
6371           enddo     ! kk
6372         enddo       ! jj
6373
6374         ENDDO ! ISHIFT
6375
6376       enddo         ! i
6377       return
6378       end
6379 c------------------------------------------------------------------------------
6380       double precision function esccorr(i,j,k,l,jj,kk)
6381       implicit real*8 (a-h,o-z)
6382       include 'DIMENSIONS'
6383       include 'COMMON.IOUNITS'
6384       include 'COMMON.DERIV'
6385       include 'COMMON.INTERACT'
6386       include 'COMMON.CONTACTS'
6387       double precision gx(3),gx1(3)
6388       logical lprn
6389       lprn=.false.
6390       eij=facont(jj,i)
6391       ekl=facont(kk,k)
6392 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6393 C Calculate the multi-body contribution to energy.
6394 C Calculate multi-body contributions to the gradient.
6395 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6396 cd   & k,l,(gacont(m,kk,k),m=1,3)
6397       do m=1,3
6398         gx(m) =ekl*gacont(m,jj,i)
6399         gx1(m)=eij*gacont(m,kk,k)
6400         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6401         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6402         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6403         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6404       enddo
6405       do m=i,j-1
6406         do ll=1,3
6407           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6408         enddo
6409       enddo
6410       do m=k,l-1
6411         do ll=1,3
6412           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6413         enddo
6414       enddo
6415       esccorr=-eij*ekl
6416       return
6417       end
6418 c------------------------------------------------------------------------------
6419 #ifdef MPL
6420       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
6421       implicit real*8 (a-h,o-z)
6422       include 'DIMENSIONS'
6423       integer dimen1,dimen2,atom,indx
6424       double precision buffer(dimen1,dimen2)
6425       double precision zapas
6426       common /contacts_hb/ zapas(3,20,maxres,7),
6427      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6428      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6429       num_kont=num_cont_hb(atom)
6430       do i=1,num_kont
6431         do k=1,7
6432           do j=1,3
6433             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
6434           enddo ! j
6435         enddo ! k
6436         buffer(i,indx+22)=facont_hb(i,atom)
6437         buffer(i,indx+23)=ees0p(i,atom)
6438         buffer(i,indx+24)=ees0m(i,atom)
6439         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
6440       enddo ! i
6441       buffer(1,indx+26)=dfloat(num_kont)
6442       return
6443       end
6444 c------------------------------------------------------------------------------
6445       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
6446       implicit real*8 (a-h,o-z)
6447       include 'DIMENSIONS'
6448       integer dimen1,dimen2,atom,indx
6449       double precision buffer(dimen1,dimen2)
6450       double precision zapas
6451       common /contacts_hb/ zapas(3,20,maxres,7),
6452      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6453      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6454       num_kont=buffer(1,indx+26)
6455       num_kont_old=num_cont_hb(atom)
6456       num_cont_hb(atom)=num_kont+num_kont_old
6457       do i=1,num_kont
6458         ii=i+num_kont_old
6459         do k=1,7
6460           do j=1,3
6461             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
6462           enddo ! j
6463         enddo ! k
6464         facont_hb(ii,atom)=buffer(i,indx+22)
6465         ees0p(ii,atom)=buffer(i,indx+23)
6466         ees0m(ii,atom)=buffer(i,indx+24)
6467         jcont_hb(ii,atom)=buffer(i,indx+25)
6468       enddo ! i
6469       return
6470       end
6471 c------------------------------------------------------------------------------
6472 #endif
6473       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6474 C This subroutine calculates multi-body contributions to hydrogen-bonding
6475       implicit real*8 (a-h,o-z)
6476       include 'DIMENSIONS'
6477       include 'DIMENSIONS.ZSCOPT'
6478       include 'COMMON.IOUNITS'
6479 #ifdef MPL
6480       include 'COMMON.INFO'
6481 #endif
6482       include 'COMMON.FFIELD'
6483       include 'COMMON.DERIV'
6484       include 'COMMON.INTERACT'
6485       include 'COMMON.CONTACTS'
6486 #ifdef MPL
6487       parameter (max_cont=maxconts)
6488       parameter (max_dim=2*(8*3+2))
6489       parameter (msglen1=max_cont*max_dim*4)
6490       parameter (msglen2=2*msglen1)
6491       integer source,CorrelType,CorrelID,Error
6492       double precision buffer(max_cont,max_dim)
6493 #endif
6494       double precision gx(3),gx1(3)
6495       logical lprn,ldone
6496
6497 C Set lprn=.true. for debugging
6498       lprn=.false.
6499 #ifdef MPL
6500       n_corr=0
6501       n_corr1=0
6502       if (fgProcs.le.1) goto 30
6503       if (lprn) then
6504         write (iout,'(a)') 'Contact function values:'
6505         do i=nnt,nct-2
6506           write (iout,'(2i3,50(1x,i2,f5.2))')
6507      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6508      &    j=1,num_cont_hb(i))
6509         enddo
6510       endif
6511 C Caution! Following code assumes that electrostatic interactions concerning
6512 C a given atom are split among at most two processors!
6513       CorrelType=477
6514       CorrelID=MyID+1
6515       ldone=.false.
6516       do i=1,max_cont
6517         do j=1,max_dim
6518           buffer(i,j)=0.0D0
6519         enddo
6520       enddo
6521       mm=mod(MyRank,2)
6522 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6523       if (mm) 20,20,10
6524    10 continue
6525 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6526       if (MyRank.gt.0) then
6527 C Send correlation contributions to the preceding processor
6528         msglen=msglen1
6529         nn=num_cont_hb(iatel_s)
6530         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6531 cd      write (iout,*) 'The BUFFER array:'
6532 cd      do i=1,nn
6533 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6534 cd      enddo
6535         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6536           msglen=msglen2
6537             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6538 C Clear the contacts of the atom passed to the neighboring processor
6539         nn=num_cont_hb(iatel_s+1)
6540 cd      do i=1,nn
6541 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6542 cd      enddo
6543             num_cont_hb(iatel_s)=0
6544         endif
6545 cd      write (iout,*) 'Processor ',MyID,MyRank,
6546 cd   & ' is sending correlation contribution to processor',MyID-1,
6547 cd   & ' msglen=',msglen
6548 cd      write (*,*) 'Processor ',MyID,MyRank,
6549 cd   & ' is sending correlation contribution to processor',MyID-1,
6550 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6551         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6552 cd      write (iout,*) 'Processor ',MyID,
6553 cd   & ' has sent correlation contribution to processor',MyID-1,
6554 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6555 cd      write (*,*) 'Processor ',MyID,
6556 cd   & ' has sent correlation contribution to processor',MyID-1,
6557 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6558         msglen=msglen1
6559       endif ! (MyRank.gt.0)
6560       if (ldone) goto 30
6561       ldone=.true.
6562    20 continue
6563 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6564       if (MyRank.lt.fgProcs-1) then
6565 C Receive correlation contributions from the next processor
6566         msglen=msglen1
6567         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6568 cd      write (iout,*) 'Processor',MyID,
6569 cd   & ' is receiving correlation contribution from processor',MyID+1,
6570 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6571 cd      write (*,*) 'Processor',MyID,
6572 cd   & ' is receiving correlation contribution from processor',MyID+1,
6573 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6574         nbytes=-1
6575         do while (nbytes.le.0)
6576           call mp_probe(MyID+1,CorrelType,nbytes)
6577         enddo
6578 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6579         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6580 cd      write (iout,*) 'Processor',MyID,
6581 cd   & ' has received correlation contribution from processor',MyID+1,
6582 cd   & ' msglen=',msglen,' nbytes=',nbytes
6583 cd      write (iout,*) 'The received BUFFER array:'
6584 cd      do i=1,max_cont
6585 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6586 cd      enddo
6587         if (msglen.eq.msglen1) then
6588           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6589         else if (msglen.eq.msglen2)  then
6590           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6591           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6592         else
6593           write (iout,*)
6594      & 'ERROR!!!! message length changed while processing correlations.'
6595           write (*,*)
6596      & 'ERROR!!!! message length changed while processing correlations.'
6597           call mp_stopall(Error)
6598         endif ! msglen.eq.msglen1
6599       endif ! MyRank.lt.fgProcs-1
6600       if (ldone) goto 30
6601       ldone=.true.
6602       goto 10
6603    30 continue
6604 #endif
6605       if (lprn) then
6606         write (iout,'(a)') 'Contact function values:'
6607         do i=nnt,nct-2
6608           write (iout,'(2i3,50(1x,i2,f5.2))')
6609      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6610      &    j=1,num_cont_hb(i))
6611         enddo
6612       endif
6613       ecorr=0.0D0
6614 C Remove the loop below after debugging !!!
6615       do i=nnt,nct
6616         do j=1,3
6617           gradcorr(j,i)=0.0D0
6618           gradxorr(j,i)=0.0D0
6619         enddo
6620       enddo
6621 C Calculate the local-electrostatic correlation terms
6622       do i=iatel_s,iatel_e+1
6623         i1=i+1
6624         num_conti=num_cont_hb(i)
6625         num_conti1=num_cont_hb(i+1)
6626         do jj=1,num_conti
6627           j=jcont_hb(jj,i)
6628           do kk=1,num_conti1
6629             j1=jcont_hb(kk,i1)
6630 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6631 c     &         ' jj=',jj,' kk=',kk
6632             if (j1.eq.j+1 .or. j1.eq.j-1) then
6633 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6634 C The system gains extra energy.
6635               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6636               n_corr=n_corr+1
6637             else if (j1.eq.j) then
6638 C Contacts I-J and I-(J+1) occur simultaneously.
6639 C The system loses extra energy.
6640 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6641             endif
6642           enddo ! kk
6643           do kk=1,num_conti
6644             j1=jcont_hb(kk,i)
6645 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6646 c    &         ' jj=',jj,' kk=',kk
6647             if (j1.eq.j+1) then
6648 C Contacts I-J and (I+1)-J occur simultaneously.
6649 C The system loses extra energy.
6650 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6651             endif ! j1==j+1
6652           enddo ! kk
6653         enddo ! jj
6654       enddo ! i
6655       return
6656       end
6657 c------------------------------------------------------------------------------
6658       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6659      &  n_corr1)
6660 C This subroutine calculates multi-body contributions to hydrogen-bonding
6661       implicit real*8 (a-h,o-z)
6662       include 'DIMENSIONS'
6663       include 'DIMENSIONS.ZSCOPT'
6664       include 'COMMON.IOUNITS'
6665 #ifdef MPL
6666       include 'COMMON.INFO'
6667 #endif
6668       include 'COMMON.FFIELD'
6669       include 'COMMON.DERIV'
6670       include 'COMMON.INTERACT'
6671       include 'COMMON.CONTACTS'
6672 #ifdef MPL
6673       parameter (max_cont=maxconts)
6674       parameter (max_dim=2*(8*3+2))
6675       parameter (msglen1=max_cont*max_dim*4)
6676       parameter (msglen2=2*msglen1)
6677       integer source,CorrelType,CorrelID,Error
6678       double precision buffer(max_cont,max_dim)
6679 #endif
6680       double precision gx(3),gx1(3)
6681       logical lprn,ldone
6682
6683 C Set lprn=.true. for debugging
6684       lprn=.false.
6685       eturn6=0.0d0
6686 #ifdef MPL
6687       n_corr=0
6688       n_corr1=0
6689       if (fgProcs.le.1) goto 30
6690       if (lprn) then
6691         write (iout,'(a)') 'Contact function values:'
6692         do i=nnt,nct-2
6693           write (iout,'(2i3,50(1x,i2,f5.2))')
6694      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6695      &    j=1,num_cont_hb(i))
6696         enddo
6697       endif
6698 C Caution! Following code assumes that electrostatic interactions concerning
6699 C a given atom are split among at most two processors!
6700       CorrelType=477
6701       CorrelID=MyID+1
6702       ldone=.false.
6703       do i=1,max_cont
6704         do j=1,max_dim
6705           buffer(i,j)=0.0D0
6706         enddo
6707       enddo
6708       mm=mod(MyRank,2)
6709 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6710       if (mm) 20,20,10
6711    10 continue
6712 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6713       if (MyRank.gt.0) then
6714 C Send correlation contributions to the preceding processor
6715         msglen=msglen1
6716         nn=num_cont_hb(iatel_s)
6717         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6718 cd      write (iout,*) 'The BUFFER array:'
6719 cd      do i=1,nn
6720 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6721 cd      enddo
6722         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6723           msglen=msglen2
6724             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6725 C Clear the contacts of the atom passed to the neighboring processor
6726         nn=num_cont_hb(iatel_s+1)
6727 cd      do i=1,nn
6728 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6729 cd      enddo
6730             num_cont_hb(iatel_s)=0
6731         endif
6732 cd      write (iout,*) 'Processor ',MyID,MyRank,
6733 cd   & ' is sending correlation contribution to processor',MyID-1,
6734 cd   & ' msglen=',msglen
6735 cd      write (*,*) 'Processor ',MyID,MyRank,
6736 cd   & ' is sending correlation contribution to processor',MyID-1,
6737 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6738         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6739 cd      write (iout,*) 'Processor ',MyID,
6740 cd   & ' has sent correlation contribution to processor',MyID-1,
6741 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6742 cd      write (*,*) 'Processor ',MyID,
6743 cd   & ' has sent correlation contribution to processor',MyID-1,
6744 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6745         msglen=msglen1
6746       endif ! (MyRank.gt.0)
6747       if (ldone) goto 30
6748       ldone=.true.
6749    20 continue
6750 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6751       if (MyRank.lt.fgProcs-1) then
6752 C Receive correlation contributions from the next processor
6753         msglen=msglen1
6754         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6755 cd      write (iout,*) 'Processor',MyID,
6756 cd   & ' is receiving correlation contribution from processor',MyID+1,
6757 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6758 cd      write (*,*) 'Processor',MyID,
6759 cd   & ' is receiving correlation contribution from processor',MyID+1,
6760 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6761         nbytes=-1
6762         do while (nbytes.le.0)
6763           call mp_probe(MyID+1,CorrelType,nbytes)
6764         enddo
6765 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6766         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6767 cd      write (iout,*) 'Processor',MyID,
6768 cd   & ' has received correlation contribution from processor',MyID+1,
6769 cd   & ' msglen=',msglen,' nbytes=',nbytes
6770 cd      write (iout,*) 'The received BUFFER array:'
6771 cd      do i=1,max_cont
6772 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6773 cd      enddo
6774         if (msglen.eq.msglen1) then
6775           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6776         else if (msglen.eq.msglen2)  then
6777           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6778           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6779         else
6780           write (iout,*)
6781      & 'ERROR!!!! message length changed while processing correlations.'
6782           write (*,*)
6783      & 'ERROR!!!! message length changed while processing correlations.'
6784           call mp_stopall(Error)
6785         endif ! msglen.eq.msglen1
6786       endif ! MyRank.lt.fgProcs-1
6787       if (ldone) goto 30
6788       ldone=.true.
6789       goto 10
6790    30 continue
6791 #endif
6792       if (lprn) then
6793         write (iout,'(a)') 'Contact function values:'
6794         do i=nnt,nct-2
6795           write (iout,'(2i3,50(1x,i2,f5.2))')
6796      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6797      &    j=1,num_cont_hb(i))
6798         enddo
6799       endif
6800       ecorr=0.0D0
6801       ecorr5=0.0d0
6802       ecorr6=0.0d0
6803 C Remove the loop below after debugging !!!
6804       do i=nnt,nct
6805         do j=1,3
6806           gradcorr(j,i)=0.0D0
6807           gradxorr(j,i)=0.0D0
6808         enddo
6809       enddo
6810 C Calculate the dipole-dipole interaction energies
6811       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6812       do i=iatel_s,iatel_e+1
6813         num_conti=num_cont_hb(i)
6814         do jj=1,num_conti
6815           j=jcont_hb(jj,i)
6816           call dipole(i,j,jj)
6817         enddo
6818       enddo
6819       endif
6820 C Calculate the local-electrostatic correlation terms
6821       do i=iatel_s,iatel_e+1
6822         i1=i+1
6823         num_conti=num_cont_hb(i)
6824         num_conti1=num_cont_hb(i+1)
6825         do jj=1,num_conti
6826           j=jcont_hb(jj,i)
6827           do kk=1,num_conti1
6828             j1=jcont_hb(kk,i1)
6829 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6830 c     &         ' jj=',jj,' kk=',kk
6831             if (j1.eq.j+1 .or. j1.eq.j-1) then
6832 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6833 C The system gains extra energy.
6834               n_corr=n_corr+1
6835               sqd1=dsqrt(d_cont(jj,i))
6836               sqd2=dsqrt(d_cont(kk,i1))
6837               sred_geom = sqd1*sqd2
6838               IF (sred_geom.lt.cutoff_corr) THEN
6839                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6840      &            ekont,fprimcont)
6841 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6842 c     &         ' jj=',jj,' kk=',kk
6843                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6844                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6845                 do l=1,3
6846                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6847                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6848                 enddo
6849                 n_corr1=n_corr1+1
6850 cd               write (iout,*) 'sred_geom=',sred_geom,
6851 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6852                 call calc_eello(i,j,i+1,j1,jj,kk)
6853                 if (wcorr4.gt.0.0d0)
6854      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6855                 if (wcorr5.gt.0.0d0)
6856      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6857 c                print *,"wcorr5",ecorr5
6858 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6859 cd                write(2,*)'ijkl',i,j,i+1,j1
6860                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6861      &               .or. wturn6.eq.0.0d0))then
6862 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6863                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6864 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6865 cd     &            'ecorr6=',ecorr6
6866 cd                write (iout,'(4e15.5)') sred_geom,
6867 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6868 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6869 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6870                 else if (wturn6.gt.0.0d0
6871      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6872 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6873                   eturn6=eturn6+eello_turn6(i,jj,kk)
6874 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6875                 endif
6876               ENDIF
6877 1111          continue
6878             else if (j1.eq.j) then
6879 C Contacts I-J and I-(J+1) occur simultaneously.
6880 C The system loses extra energy.
6881 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6882             endif
6883           enddo ! kk
6884           do kk=1,num_conti
6885             j1=jcont_hb(kk,i)
6886 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6887 c    &         ' jj=',jj,' kk=',kk
6888             if (j1.eq.j+1) then
6889 C Contacts I-J and (I+1)-J occur simultaneously.
6890 C The system loses extra energy.
6891 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6892             endif ! j1==j+1
6893           enddo ! kk
6894         enddo ! jj
6895       enddo ! i
6896       return
6897       end
6898 c------------------------------------------------------------------------------
6899       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6900       implicit real*8 (a-h,o-z)
6901       include 'DIMENSIONS'
6902       include 'COMMON.IOUNITS'
6903       include 'COMMON.DERIV'
6904       include 'COMMON.INTERACT'
6905       include 'COMMON.CONTACTS'
6906       double precision gx(3),gx1(3)
6907       logical lprn
6908       lprn=.false.
6909       eij=facont_hb(jj,i)
6910       ekl=facont_hb(kk,k)
6911       ees0pij=ees0p(jj,i)
6912       ees0pkl=ees0p(kk,k)
6913       ees0mij=ees0m(jj,i)
6914       ees0mkl=ees0m(kk,k)
6915       ekont=eij*ekl
6916       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6917 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6918 C Following 4 lines for diagnostics.
6919 cd    ees0pkl=0.0D0
6920 cd    ees0pij=1.0D0
6921 cd    ees0mkl=0.0D0
6922 cd    ees0mij=1.0D0
6923 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6924 c    &   ' and',k,l
6925 c     write (iout,*)'Contacts have occurred for peptide groups',
6926 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6927 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6928 C Calculate the multi-body contribution to energy.
6929       ecorr=ecorr+ekont*ees
6930       if (calc_grad) then
6931 C Calculate multi-body contributions to the gradient.
6932       do ll=1,3
6933         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6934         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6935      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6936      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6937         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6938      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6939      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6940         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6941         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6942      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6943      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6944         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6945      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6946      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6947       enddo
6948       do m=i+1,j-1
6949         do ll=1,3
6950           gradcorr(ll,m)=gradcorr(ll,m)+
6951      &     ees*ekl*gacont_hbr(ll,jj,i)-
6952      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6953      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6954         enddo
6955       enddo
6956       do m=k+1,l-1
6957         do ll=1,3
6958           gradcorr(ll,m)=gradcorr(ll,m)+
6959      &     ees*eij*gacont_hbr(ll,kk,k)-
6960      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6961      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6962         enddo
6963       enddo
6964       endif
6965       ehbcorr=ekont*ees
6966       return
6967       end
6968 C---------------------------------------------------------------------------
6969       subroutine dipole(i,j,jj)
6970       implicit real*8 (a-h,o-z)
6971       include 'DIMENSIONS'
6972       include 'DIMENSIONS.ZSCOPT'
6973       include 'COMMON.IOUNITS'
6974       include 'COMMON.CHAIN'
6975       include 'COMMON.FFIELD'
6976       include 'COMMON.DERIV'
6977       include 'COMMON.INTERACT'
6978       include 'COMMON.CONTACTS'
6979       include 'COMMON.TORSION'
6980       include 'COMMON.VAR'
6981       include 'COMMON.GEO'
6982       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6983      &  auxmat(2,2)
6984       iti1 = itortyp(itype(i+1))
6985       if (j.lt.nres-1) then
6986         itj1 = itortyp(itype(j+1))
6987       else
6988         itj1=ntortyp+1
6989       endif
6990       do iii=1,2
6991         dipi(iii,1)=Ub2(iii,i)
6992         dipderi(iii)=Ub2der(iii,i)
6993         dipi(iii,2)=b1(iii,iti1)
6994         dipj(iii,1)=Ub2(iii,j)
6995         dipderj(iii)=Ub2der(iii,j)
6996         dipj(iii,2)=b1(iii,itj1)
6997       enddo
6998       kkk=0
6999       do iii=1,2
7000         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7001         do jjj=1,2
7002           kkk=kkk+1
7003           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7004         enddo
7005       enddo
7006       if (.not.calc_grad) return
7007       do kkk=1,5
7008         do lll=1,3
7009           mmm=0
7010           do iii=1,2
7011             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7012      &        auxvec(1))
7013             do jjj=1,2
7014               mmm=mmm+1
7015               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7016             enddo
7017           enddo
7018         enddo
7019       enddo
7020       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7021       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7022       do iii=1,2
7023         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7024       enddo
7025       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7026       do iii=1,2
7027         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7028       enddo
7029       return
7030       end
7031 C---------------------------------------------------------------------------
7032       subroutine calc_eello(i,j,k,l,jj,kk)
7033 C
7034 C This subroutine computes matrices and vectors needed to calculate
7035 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7036 C
7037       implicit real*8 (a-h,o-z)
7038       include 'DIMENSIONS'
7039       include 'DIMENSIONS.ZSCOPT'
7040       include 'COMMON.IOUNITS'
7041       include 'COMMON.CHAIN'
7042       include 'COMMON.DERIV'
7043       include 'COMMON.INTERACT'
7044       include 'COMMON.CONTACTS'
7045       include 'COMMON.TORSION'
7046       include 'COMMON.VAR'
7047       include 'COMMON.GEO'
7048       include 'COMMON.FFIELD'
7049       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7050      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7051       logical lprn
7052       common /kutas/ lprn
7053 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7054 cd     & ' jj=',jj,' kk=',kk
7055 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7056       do iii=1,2
7057         do jjj=1,2
7058           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7059           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7060         enddo
7061       enddo
7062       call transpose2(aa1(1,1),aa1t(1,1))
7063       call transpose2(aa2(1,1),aa2t(1,1))
7064       do kkk=1,5
7065         do lll=1,3
7066           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7067      &      aa1tder(1,1,lll,kkk))
7068           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7069      &      aa2tder(1,1,lll,kkk))
7070         enddo
7071       enddo
7072       if (l.eq.j+1) then
7073 C parallel orientation of the two CA-CA-CA frames.
7074         if (i.gt.1) then
7075           iti=itortyp(itype(i))
7076         else
7077           iti=ntortyp+1
7078         endif
7079         itk1=itortyp(itype(k+1))
7080         itj=itortyp(itype(j))
7081         if (l.lt.nres-1) then
7082           itl1=itortyp(itype(l+1))
7083         else
7084           itl1=ntortyp+1
7085         endif
7086 C A1 kernel(j+1) A2T
7087 cd        do iii=1,2
7088 cd          write (iout,'(3f10.5,5x,3f10.5)')
7089 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7090 cd        enddo
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.,EUg(1,1,l),EUgder(1,1,l),
7093      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7094 C Following matrices are needed only for 6-th order cumulants
7095         IF (wcorr6.gt.0.0d0) THEN
7096         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7097      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7098      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
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.,Ug2DtEUg(1,1,l),
7101      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7102      &   ADtEAderx(1,1,1,1,1,1))
7103         lprn=.false.
7104         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7105      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7106      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7107      &   ADtEA1derx(1,1,1,1,1,1))
7108         ENDIF
7109 C End 6-th order cumulants
7110 cd        lprn=.false.
7111 cd        if (lprn) then
7112 cd        write (2,*) 'In calc_eello6'
7113 cd        do iii=1,2
7114 cd          write (2,*) 'iii=',iii
7115 cd          do kkk=1,5
7116 cd            write (2,*) 'kkk=',kkk
7117 cd            do jjj=1,2
7118 cd              write (2,'(3(2f10.5),5x)')
7119 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7120 cd            enddo
7121 cd          enddo
7122 cd        enddo
7123 cd        endif
7124         call transpose2(EUgder(1,1,k),auxmat(1,1))
7125         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7126         call transpose2(EUg(1,1,k),auxmat(1,1))
7127         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7128         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7129         do iii=1,2
7130           do kkk=1,5
7131             do lll=1,3
7132               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7133      &          EAEAderx(1,1,lll,kkk,iii,1))
7134             enddo
7135           enddo
7136         enddo
7137 C A1T kernel(i+1) A2
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.,EUg(1,1,k),EUgder(1,1,k),
7140      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7141 C Following matrices are needed only for 6-th order cumulants
7142         IF (wcorr6.gt.0.0d0) THEN
7143         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7144      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7145      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7146         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7147      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7148      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7149      &   ADtEAderx(1,1,1,1,1,2))
7150         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7151      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7152      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7153      &   ADtEA1derx(1,1,1,1,1,2))
7154         ENDIF
7155 C End 6-th order cumulants
7156         call transpose2(EUgder(1,1,l),auxmat(1,1))
7157         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7158         call transpose2(EUg(1,1,l),auxmat(1,1))
7159         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7160         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7161         do iii=1,2
7162           do kkk=1,5
7163             do lll=1,3
7164               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7165      &          EAEAderx(1,1,lll,kkk,iii,2))
7166             enddo
7167           enddo
7168         enddo
7169 C AEAb1 and AEAb2
7170 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7171 C They are needed only when the fifth- or the sixth-order cumulants are
7172 C indluded.
7173         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7174         call transpose2(AEA(1,1,1),auxmat(1,1))
7175         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7176         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7177         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7178         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7179         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7180         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7181         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7182         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7183         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7184         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7185         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7186         call transpose2(AEA(1,1,2),auxmat(1,1))
7187         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7188         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7189         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7190         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7191         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7192         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7193         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7194         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7195         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7196         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7197         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7198 C Calculate the Cartesian derivatives of the vectors.
7199         do iii=1,2
7200           do kkk=1,5
7201             do lll=1,3
7202               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7203               call matvec2(auxmat(1,1),b1(1,iti),
7204      &          AEAb1derx(1,lll,kkk,iii,1,1))
7205               call matvec2(auxmat(1,1),Ub2(1,i),
7206      &          AEAb2derx(1,lll,kkk,iii,1,1))
7207               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7208      &          AEAb1derx(1,lll,kkk,iii,2,1))
7209               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7210      &          AEAb2derx(1,lll,kkk,iii,2,1))
7211               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7212               call matvec2(auxmat(1,1),b1(1,itj),
7213      &          AEAb1derx(1,lll,kkk,iii,1,2))
7214               call matvec2(auxmat(1,1),Ub2(1,j),
7215      &          AEAb2derx(1,lll,kkk,iii,1,2))
7216               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7217      &          AEAb1derx(1,lll,kkk,iii,2,2))
7218               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7219      &          AEAb2derx(1,lll,kkk,iii,2,2))
7220             enddo
7221           enddo
7222         enddo
7223         ENDIF
7224 C End vectors
7225       else
7226 C Antiparallel orientation of the two CA-CA-CA frames.
7227         if (i.gt.1) then
7228           iti=itortyp(itype(i))
7229         else
7230           iti=ntortyp+1
7231         endif
7232         itk1=itortyp(itype(k+1))
7233         itl=itortyp(itype(l))
7234         itj=itortyp(itype(j))
7235         if (j.lt.nres-1) then
7236           itj1=itortyp(itype(j+1))
7237         else
7238           itj1=ntortyp+1
7239         endif
7240 C A2 kernel(j-1)T A1T
7241         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7242      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7243      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7244 C Following matrices are needed only for 6-th order cumulants
7245         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7246      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7247         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7248      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7249      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7250         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7251      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7252      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7253      &   ADtEAderx(1,1,1,1,1,1))
7254         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7255      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7256      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7257      &   ADtEA1derx(1,1,1,1,1,1))
7258         ENDIF
7259 C End 6-th order cumulants
7260         call transpose2(EUgder(1,1,k),auxmat(1,1))
7261         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7262         call transpose2(EUg(1,1,k),auxmat(1,1))
7263         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7264         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7265         do iii=1,2
7266           do kkk=1,5
7267             do lll=1,3
7268               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7269      &          EAEAderx(1,1,lll,kkk,iii,1))
7270             enddo
7271           enddo
7272         enddo
7273 C A2T kernel(i+1)T A1
7274         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7275      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7276      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7277 C Following matrices are needed only for 6-th order cumulants
7278         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7279      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7280         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7281      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7282      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7283         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7284      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7285      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7286      &   ADtEAderx(1,1,1,1,1,2))
7287         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7288      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7289      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7290      &   ADtEA1derx(1,1,1,1,1,2))
7291         ENDIF
7292 C End 6-th order cumulants
7293         call transpose2(EUgder(1,1,j),auxmat(1,1))
7294         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7295         call transpose2(EUg(1,1,j),auxmat(1,1))
7296         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7297         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7298         do iii=1,2
7299           do kkk=1,5
7300             do lll=1,3
7301               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7302      &          EAEAderx(1,1,lll,kkk,iii,2))
7303             enddo
7304           enddo
7305         enddo
7306 C AEAb1 and AEAb2
7307 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7308 C They are needed only when the fifth- or the sixth-order cumulants are
7309 C indluded.
7310         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7311      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7312         call transpose2(AEA(1,1,1),auxmat(1,1))
7313         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7314         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7315         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7316         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7317         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7318         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7319         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7320         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7321         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7322         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7323         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7324         call transpose2(AEA(1,1,2),auxmat(1,1))
7325         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7326         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7327         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7328         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7329         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7330         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7331         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7332         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7333         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7334         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7335         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7336 C Calculate the Cartesian derivatives of the vectors.
7337         do iii=1,2
7338           do kkk=1,5
7339             do lll=1,3
7340               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7341               call matvec2(auxmat(1,1),b1(1,iti),
7342      &          AEAb1derx(1,lll,kkk,iii,1,1))
7343               call matvec2(auxmat(1,1),Ub2(1,i),
7344      &          AEAb2derx(1,lll,kkk,iii,1,1))
7345               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7346      &          AEAb1derx(1,lll,kkk,iii,2,1))
7347               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7348      &          AEAb2derx(1,lll,kkk,iii,2,1))
7349               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7350               call matvec2(auxmat(1,1),b1(1,itl),
7351      &          AEAb1derx(1,lll,kkk,iii,1,2))
7352               call matvec2(auxmat(1,1),Ub2(1,l),
7353      &          AEAb2derx(1,lll,kkk,iii,1,2))
7354               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7355      &          AEAb1derx(1,lll,kkk,iii,2,2))
7356               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7357      &          AEAb2derx(1,lll,kkk,iii,2,2))
7358             enddo
7359           enddo
7360         enddo
7361         ENDIF
7362 C End vectors
7363       endif
7364       return
7365       end
7366 C---------------------------------------------------------------------------
7367       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7368      &  KK,KKderg,AKA,AKAderg,AKAderx)
7369       implicit none
7370       integer nderg
7371       logical transp
7372       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7373      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7374      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7375       integer iii,kkk,lll
7376       integer jjj,mmm
7377       logical lprn
7378       common /kutas/ lprn
7379       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7380       do iii=1,nderg
7381         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7382      &    AKAderg(1,1,iii))
7383       enddo
7384 cd      if (lprn) write (2,*) 'In kernel'
7385       do kkk=1,5
7386 cd        if (lprn) write (2,*) 'kkk=',kkk
7387         do lll=1,3
7388           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7389      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7390 cd          if (lprn) then
7391 cd            write (2,*) 'lll=',lll
7392 cd            write (2,*) 'iii=1'
7393 cd            do jjj=1,2
7394 cd              write (2,'(3(2f10.5),5x)')
7395 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7396 cd            enddo
7397 cd          endif
7398           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7399      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7400 cd          if (lprn) then
7401 cd            write (2,*) 'lll=',lll
7402 cd            write (2,*) 'iii=2'
7403 cd            do jjj=1,2
7404 cd              write (2,'(3(2f10.5),5x)')
7405 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7406 cd            enddo
7407 cd          endif
7408         enddo
7409       enddo
7410       return
7411       end
7412 C---------------------------------------------------------------------------
7413       double precision function eello4(i,j,k,l,jj,kk)
7414       implicit real*8 (a-h,o-z)
7415       include 'DIMENSIONS'
7416       include 'DIMENSIONS.ZSCOPT'
7417       include 'COMMON.IOUNITS'
7418       include 'COMMON.CHAIN'
7419       include 'COMMON.DERIV'
7420       include 'COMMON.INTERACT'
7421       include 'COMMON.CONTACTS'
7422       include 'COMMON.TORSION'
7423       include 'COMMON.VAR'
7424       include 'COMMON.GEO'
7425       double precision pizda(2,2),ggg1(3),ggg2(3)
7426 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7427 cd        eello4=0.0d0
7428 cd        return
7429 cd      endif
7430 cd      print *,'eello4:',i,j,k,l,jj,kk
7431 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7432 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7433 cold      eij=facont_hb(jj,i)
7434 cold      ekl=facont_hb(kk,k)
7435 cold      ekont=eij*ekl
7436       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7437       if (calc_grad) then
7438 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7439       gcorr_loc(k-1)=gcorr_loc(k-1)
7440      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7441       if (l.eq.j+1) then
7442         gcorr_loc(l-1)=gcorr_loc(l-1)
7443      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7444       else
7445         gcorr_loc(j-1)=gcorr_loc(j-1)
7446      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7447       endif
7448       do iii=1,2
7449         do kkk=1,5
7450           do lll=1,3
7451             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7452      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7453 cd            derx(lll,kkk,iii)=0.0d0
7454           enddo
7455         enddo
7456       enddo
7457 cd      gcorr_loc(l-1)=0.0d0
7458 cd      gcorr_loc(j-1)=0.0d0
7459 cd      gcorr_loc(k-1)=0.0d0
7460 cd      eel4=1.0d0
7461 cd      write (iout,*)'Contacts have occurred for peptide groups',
7462 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7463 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7464       if (j.lt.nres-1) then
7465         j1=j+1
7466         j2=j-1
7467       else
7468         j1=j-1
7469         j2=j-2
7470       endif
7471       if (l.lt.nres-1) then
7472         l1=l+1
7473         l2=l-1
7474       else
7475         l1=l-1
7476         l2=l-2
7477       endif
7478       do ll=1,3
7479 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
7480         ggg1(ll)=eel4*g_contij(ll,1)
7481         ggg2(ll)=eel4*g_contij(ll,2)
7482         ghalf=0.5d0*ggg1(ll)
7483 cd        ghalf=0.0d0
7484         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
7485         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7486         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
7487         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7488 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
7489         ghalf=0.5d0*ggg2(ll)
7490 cd        ghalf=0.0d0
7491         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
7492         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7493         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
7494         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7495       enddo
7496 cd      goto 1112
7497       do m=i+1,j-1
7498         do ll=1,3
7499 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
7500           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7501         enddo
7502       enddo
7503       do m=k+1,l-1
7504         do ll=1,3
7505 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
7506           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7507         enddo
7508       enddo
7509 1112  continue
7510       do m=i+2,j2
7511         do ll=1,3
7512           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7513         enddo
7514       enddo
7515       do m=k+2,l2
7516         do ll=1,3
7517           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7518         enddo
7519       enddo
7520 cd      do iii=1,nres-3
7521 cd        write (2,*) iii,gcorr_loc(iii)
7522 cd      enddo
7523       endif
7524       eello4=ekont*eel4
7525 cd      write (2,*) 'ekont',ekont
7526 cd      write (iout,*) 'eello4',ekont*eel4
7527       return
7528       end
7529 C---------------------------------------------------------------------------
7530       double precision function eello5(i,j,k,l,jj,kk)
7531       implicit real*8 (a-h,o-z)
7532       include 'DIMENSIONS'
7533       include 'DIMENSIONS.ZSCOPT'
7534       include 'COMMON.IOUNITS'
7535       include 'COMMON.CHAIN'
7536       include 'COMMON.DERIV'
7537       include 'COMMON.INTERACT'
7538       include 'COMMON.CONTACTS'
7539       include 'COMMON.TORSION'
7540       include 'COMMON.VAR'
7541       include 'COMMON.GEO'
7542       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7543       double precision ggg1(3),ggg2(3)
7544 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7545 C                                                                              C
7546 C                            Parallel chains                                   C
7547 C                                                                              C
7548 C          o             o                   o             o                   C
7549 C         /l\           / \             \   / \           / \   /              C
7550 C        /   \         /   \             \ /   \         /   \ /               C
7551 C       j| o |l1       | o |              o| o |         | o |o                C
7552 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7553 C      \i/   \         /   \ /             /   \         /   \                 C
7554 C       o    k1             o                                                  C
7555 C         (I)          (II)                (III)          (IV)                 C
7556 C                                                                              C
7557 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7558 C                                                                              C
7559 C                            Antiparallel chains                               C
7560 C                                                                              C
7561 C          o             o                   o             o                   C
7562 C         /j\           / \             \   / \           / \   /              C
7563 C        /   \         /   \             \ /   \         /   \ /               C
7564 C      j1| o |l        | o |              o| o |         | o |o                C
7565 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7566 C      \i/   \         /   \ /             /   \         /   \                 C
7567 C       o     k1            o                                                  C
7568 C         (I)          (II)                (III)          (IV)                 C
7569 C                                                                              C
7570 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7571 C                                                                              C
7572 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7573 C                                                                              C
7574 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7575 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7576 cd        eello5=0.0d0
7577 cd        return
7578 cd      endif
7579 cd      write (iout,*)
7580 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7581 cd     &   ' and',k,l
7582       itk=itortyp(itype(k))
7583       itl=itortyp(itype(l))
7584       itj=itortyp(itype(j))
7585       eello5_1=0.0d0
7586       eello5_2=0.0d0
7587       eello5_3=0.0d0
7588       eello5_4=0.0d0
7589 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7590 cd     &   eel5_3_num,eel5_4_num)
7591       do iii=1,2
7592         do kkk=1,5
7593           do lll=1,3
7594             derx(lll,kkk,iii)=0.0d0
7595           enddo
7596         enddo
7597       enddo
7598 cd      eij=facont_hb(jj,i)
7599 cd      ekl=facont_hb(kk,k)
7600 cd      ekont=eij*ekl
7601 cd      write (iout,*)'Contacts have occurred for peptide groups',
7602 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7603 cd      goto 1111
7604 C Contribution from the graph I.
7605 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7606 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7607       call transpose2(EUg(1,1,k),auxmat(1,1))
7608       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7609       vv(1)=pizda(1,1)-pizda(2,2)
7610       vv(2)=pizda(1,2)+pizda(2,1)
7611       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7612      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7613       if (calc_grad) then
7614 C Explicit gradient in virtual-dihedral angles.
7615       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7616      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7617      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7618       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7619       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7620       vv(1)=pizda(1,1)-pizda(2,2)
7621       vv(2)=pizda(1,2)+pizda(2,1)
7622       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7623      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7624      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7625       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7626       vv(1)=pizda(1,1)-pizda(2,2)
7627       vv(2)=pizda(1,2)+pizda(2,1)
7628       if (l.eq.j+1) then
7629         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7630      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7631      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7632       else
7633         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7634      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7635      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7636       endif
7637 C Cartesian gradient
7638       do iii=1,2
7639         do kkk=1,5
7640           do lll=1,3
7641             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7642      &        pizda(1,1))
7643             vv(1)=pizda(1,1)-pizda(2,2)
7644             vv(2)=pizda(1,2)+pizda(2,1)
7645             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7646      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7647      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7648           enddo
7649         enddo
7650       enddo
7651 c      goto 1112
7652       endif
7653 c1111  continue
7654 C Contribution from graph II
7655       call transpose2(EE(1,1,itk),auxmat(1,1))
7656       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7657       vv(1)=pizda(1,1)+pizda(2,2)
7658       vv(2)=pizda(2,1)-pizda(1,2)
7659       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7660      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7661       if (calc_grad) then
7662 C Explicit gradient in virtual-dihedral angles.
7663       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7664      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7665       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7666       vv(1)=pizda(1,1)+pizda(2,2)
7667       vv(2)=pizda(2,1)-pizda(1,2)
7668       if (l.eq.j+1) then
7669         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7670      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7671      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7672       else
7673         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7674      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7675      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7676       endif
7677 C Cartesian gradient
7678       do iii=1,2
7679         do kkk=1,5
7680           do lll=1,3
7681             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7682      &        pizda(1,1))
7683             vv(1)=pizda(1,1)+pizda(2,2)
7684             vv(2)=pizda(2,1)-pizda(1,2)
7685             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7686      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7687      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7688           enddo
7689         enddo
7690       enddo
7691 cd      goto 1112
7692       endif
7693 cd1111  continue
7694       if (l.eq.j+1) then
7695 cd        goto 1110
7696 C Parallel orientation
7697 C Contribution from graph III
7698         call transpose2(EUg(1,1,l),auxmat(1,1))
7699         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7700         vv(1)=pizda(1,1)-pizda(2,2)
7701         vv(2)=pizda(1,2)+pizda(2,1)
7702         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7703      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7704         if (calc_grad) then
7705 C Explicit gradient in virtual-dihedral angles.
7706         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7707      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7708      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7709         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7710         vv(1)=pizda(1,1)-pizda(2,2)
7711         vv(2)=pizda(1,2)+pizda(2,1)
7712         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7713      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7714      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7715         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7716         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7717         vv(1)=pizda(1,1)-pizda(2,2)
7718         vv(2)=pizda(1,2)+pizda(2,1)
7719         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7720      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7721      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7722 C Cartesian gradient
7723         do iii=1,2
7724           do kkk=1,5
7725             do lll=1,3
7726               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7727      &          pizda(1,1))
7728               vv(1)=pizda(1,1)-pizda(2,2)
7729               vv(2)=pizda(1,2)+pizda(2,1)
7730               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7731      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7732      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7733             enddo
7734           enddo
7735         enddo
7736 cd        goto 1112
7737         endif
7738 C Contribution from graph IV
7739 cd1110    continue
7740         call transpose2(EE(1,1,itl),auxmat(1,1))
7741         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7742         vv(1)=pizda(1,1)+pizda(2,2)
7743         vv(2)=pizda(2,1)-pizda(1,2)
7744         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7745      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7746         if (calc_grad) then
7747 C Explicit gradient in virtual-dihedral angles.
7748         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7749      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7750         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7751         vv(1)=pizda(1,1)+pizda(2,2)
7752         vv(2)=pizda(2,1)-pizda(1,2)
7753         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7754      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7755      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7756 C Cartesian gradient
7757         do iii=1,2
7758           do kkk=1,5
7759             do lll=1,3
7760               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7761      &          pizda(1,1))
7762               vv(1)=pizda(1,1)+pizda(2,2)
7763               vv(2)=pizda(2,1)-pizda(1,2)
7764               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7765      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7766      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7767             enddo
7768           enddo
7769         enddo
7770         endif
7771       else
7772 C Antiparallel orientation
7773 C Contribution from graph III
7774 c        goto 1110
7775         call transpose2(EUg(1,1,j),auxmat(1,1))
7776         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7777         vv(1)=pizda(1,1)-pizda(2,2)
7778         vv(2)=pizda(1,2)+pizda(2,1)
7779         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7780      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7781         if (calc_grad) then
7782 C Explicit gradient in virtual-dihedral angles.
7783         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7784      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7785      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7786         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7787         vv(1)=pizda(1,1)-pizda(2,2)
7788         vv(2)=pizda(1,2)+pizda(2,1)
7789         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7790      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7791      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7792         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7793         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7794         vv(1)=pizda(1,1)-pizda(2,2)
7795         vv(2)=pizda(1,2)+pizda(2,1)
7796         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7797      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7798      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7799 C Cartesian gradient
7800         do iii=1,2
7801           do kkk=1,5
7802             do lll=1,3
7803               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7804      &          pizda(1,1))
7805               vv(1)=pizda(1,1)-pizda(2,2)
7806               vv(2)=pizda(1,2)+pizda(2,1)
7807               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7808      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7809      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7810             enddo
7811           enddo
7812         enddo
7813 cd        goto 1112
7814         endif
7815 C Contribution from graph IV
7816 1110    continue
7817         call transpose2(EE(1,1,itj),auxmat(1,1))
7818         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7819         vv(1)=pizda(1,1)+pizda(2,2)
7820         vv(2)=pizda(2,1)-pizda(1,2)
7821         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7822      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7823         if (calc_grad) then
7824 C Explicit gradient in virtual-dihedral angles.
7825         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7826      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7827         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7828         vv(1)=pizda(1,1)+pizda(2,2)
7829         vv(2)=pizda(2,1)-pizda(1,2)
7830         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7831      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7832      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7833 C Cartesian gradient
7834         do iii=1,2
7835           do kkk=1,5
7836             do lll=1,3
7837               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7838      &          pizda(1,1))
7839               vv(1)=pizda(1,1)+pizda(2,2)
7840               vv(2)=pizda(2,1)-pizda(1,2)
7841               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7842      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7843      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7844             enddo
7845           enddo
7846         enddo
7847       endif
7848       endif
7849 1112  continue
7850       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7851 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7852 cd        write (2,*) 'ijkl',i,j,k,l
7853 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7854 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7855 cd      endif
7856 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7857 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7858 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7859 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7860       if (calc_grad) then
7861       if (j.lt.nres-1) then
7862         j1=j+1
7863         j2=j-1
7864       else
7865         j1=j-1
7866         j2=j-2
7867       endif
7868       if (l.lt.nres-1) then
7869         l1=l+1
7870         l2=l-1
7871       else
7872         l1=l-1
7873         l2=l-2
7874       endif
7875 cd      eij=1.0d0
7876 cd      ekl=1.0d0
7877 cd      ekont=1.0d0
7878 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7879       do ll=1,3
7880         ggg1(ll)=eel5*g_contij(ll,1)
7881         ggg2(ll)=eel5*g_contij(ll,2)
7882 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7883         ghalf=0.5d0*ggg1(ll)
7884 cd        ghalf=0.0d0
7885         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7886         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7887         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7888         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7889 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7890         ghalf=0.5d0*ggg2(ll)
7891 cd        ghalf=0.0d0
7892         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7893         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7894         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7895         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7896       enddo
7897 cd      goto 1112
7898       do m=i+1,j-1
7899         do ll=1,3
7900 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7901           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7902         enddo
7903       enddo
7904       do m=k+1,l-1
7905         do ll=1,3
7906 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7907           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7908         enddo
7909       enddo
7910 c1112  continue
7911       do m=i+2,j2
7912         do ll=1,3
7913           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7914         enddo
7915       enddo
7916       do m=k+2,l2
7917         do ll=1,3
7918           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7919         enddo
7920       enddo
7921 cd      do iii=1,nres-3
7922 cd        write (2,*) iii,g_corr5_loc(iii)
7923 cd      enddo
7924       endif
7925       eello5=ekont*eel5
7926 cd      write (2,*) 'ekont',ekont
7927 cd      write (iout,*) 'eello5',ekont*eel5
7928       return
7929       end
7930 c--------------------------------------------------------------------------
7931       double precision function eello6(i,j,k,l,jj,kk)
7932       implicit real*8 (a-h,o-z)
7933       include 'DIMENSIONS'
7934       include 'DIMENSIONS.ZSCOPT'
7935       include 'COMMON.IOUNITS'
7936       include 'COMMON.CHAIN'
7937       include 'COMMON.DERIV'
7938       include 'COMMON.INTERACT'
7939       include 'COMMON.CONTACTS'
7940       include 'COMMON.TORSION'
7941       include 'COMMON.VAR'
7942       include 'COMMON.GEO'
7943       include 'COMMON.FFIELD'
7944       double precision ggg1(3),ggg2(3)
7945 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7946 cd        eello6=0.0d0
7947 cd        return
7948 cd      endif
7949 cd      write (iout,*)
7950 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7951 cd     &   ' and',k,l
7952       eello6_1=0.0d0
7953       eello6_2=0.0d0
7954       eello6_3=0.0d0
7955       eello6_4=0.0d0
7956       eello6_5=0.0d0
7957       eello6_6=0.0d0
7958 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7959 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7960       do iii=1,2
7961         do kkk=1,5
7962           do lll=1,3
7963             derx(lll,kkk,iii)=0.0d0
7964           enddo
7965         enddo
7966       enddo
7967 cd      eij=facont_hb(jj,i)
7968 cd      ekl=facont_hb(kk,k)
7969 cd      ekont=eij*ekl
7970 cd      eij=1.0d0
7971 cd      ekl=1.0d0
7972 cd      ekont=1.0d0
7973       if (l.eq.j+1) then
7974         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7975         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7976         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7977         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7978         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7979         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7980       else
7981         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7982         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7983         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7984         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7985         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7986           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7987         else
7988           eello6_5=0.0d0
7989         endif
7990         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7991       endif
7992 C If turn contributions are considered, they will be handled separately.
7993       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7994 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7995 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7996 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7997 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7998 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7999 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
8000 cd      goto 1112
8001       if (calc_grad) then
8002       if (j.lt.nres-1) then
8003         j1=j+1
8004         j2=j-1
8005       else
8006         j1=j-1
8007         j2=j-2
8008       endif
8009       if (l.lt.nres-1) then
8010         l1=l+1
8011         l2=l-1
8012       else
8013         l1=l-1
8014         l2=l-2
8015       endif
8016       do ll=1,3
8017         ggg1(ll)=eel6*g_contij(ll,1)
8018         ggg2(ll)=eel6*g_contij(ll,2)
8019 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8020         ghalf=0.5d0*ggg1(ll)
8021 cd        ghalf=0.0d0
8022         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
8023         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8024         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
8025         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8026         ghalf=0.5d0*ggg2(ll)
8027 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8028 cd        ghalf=0.0d0
8029         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
8030         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8031         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
8032         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8033       enddo
8034 cd      goto 1112
8035       do m=i+1,j-1
8036         do ll=1,3
8037 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8038           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8039         enddo
8040       enddo
8041       do m=k+1,l-1
8042         do ll=1,3
8043 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8044           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8045         enddo
8046       enddo
8047 1112  continue
8048       do m=i+2,j2
8049         do ll=1,3
8050           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8051         enddo
8052       enddo
8053       do m=k+2,l2
8054         do ll=1,3
8055           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8056         enddo
8057       enddo
8058 cd      do iii=1,nres-3
8059 cd        write (2,*) iii,g_corr6_loc(iii)
8060 cd      enddo
8061       endif
8062       eello6=ekont*eel6
8063 cd      write (2,*) 'ekont',ekont
8064 cd      write (iout,*) 'eello6',ekont*eel6
8065       return
8066       end
8067 c--------------------------------------------------------------------------
8068       double precision function eello6_graph1(i,j,k,l,imat,swap)
8069       implicit real*8 (a-h,o-z)
8070       include 'DIMENSIONS'
8071       include 'DIMENSIONS.ZSCOPT'
8072       include 'COMMON.IOUNITS'
8073       include 'COMMON.CHAIN'
8074       include 'COMMON.DERIV'
8075       include 'COMMON.INTERACT'
8076       include 'COMMON.CONTACTS'
8077       include 'COMMON.TORSION'
8078       include 'COMMON.VAR'
8079       include 'COMMON.GEO'
8080       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8081       logical swap
8082       logical lprn
8083       common /kutas/ lprn
8084 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8085 C                                                                              C
8086 C      Parallel       Antiparallel                                             C
8087 C                                                                              C
8088 C          o             o                                                     C
8089 C         /l\           /j\                                                    C
8090 C        /   \         /   \                                                   C
8091 C       /| o |         | o |\                                                  C
8092 C     \ j|/k\|  /   \  |/k\|l /                                                C
8093 C      \ /   \ /     \ /   \ /                                                 C
8094 C       o     o       o     o                                                  C
8095 C       i             i                                                        C
8096 C                                                                              C
8097 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8098       itk=itortyp(itype(k))
8099       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8100       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8101       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8102       call transpose2(EUgC(1,1,k),auxmat(1,1))
8103       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8104       vv1(1)=pizda1(1,1)-pizda1(2,2)
8105       vv1(2)=pizda1(1,2)+pizda1(2,1)
8106       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8107       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8108       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8109       s5=scalar2(vv(1),Dtobr2(1,i))
8110 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8111       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8112       if (.not. calc_grad) return
8113       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8114      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8115      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8116      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8117      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8118      & +scalar2(vv(1),Dtobr2der(1,i)))
8119       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8120       vv1(1)=pizda1(1,1)-pizda1(2,2)
8121       vv1(2)=pizda1(1,2)+pizda1(2,1)
8122       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8123       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8124       if (l.eq.j+1) then
8125         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8126      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8127      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8128      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8129      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8130       else
8131         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8132      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8133      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8134      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8135      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8136       endif
8137       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8138       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8139       vv1(1)=pizda1(1,1)-pizda1(2,2)
8140       vv1(2)=pizda1(1,2)+pizda1(2,1)
8141       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8142      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8143      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8144      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8145       do iii=1,2
8146         if (swap) then
8147           ind=3-iii
8148         else
8149           ind=iii
8150         endif
8151         do kkk=1,5
8152           do lll=1,3
8153             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8154             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8155             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8156             call transpose2(EUgC(1,1,k),auxmat(1,1))
8157             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8158      &        pizda1(1,1))
8159             vv1(1)=pizda1(1,1)-pizda1(2,2)
8160             vv1(2)=pizda1(1,2)+pizda1(2,1)
8161             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8162             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8163      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8164             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8165      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8166             s5=scalar2(vv(1),Dtobr2(1,i))
8167             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8168           enddo
8169         enddo
8170       enddo
8171       return
8172       end
8173 c----------------------------------------------------------------------------
8174       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8175       implicit real*8 (a-h,o-z)
8176       include 'DIMENSIONS'
8177       include 'DIMENSIONS.ZSCOPT'
8178       include 'COMMON.IOUNITS'
8179       include 'COMMON.CHAIN'
8180       include 'COMMON.DERIV'
8181       include 'COMMON.INTERACT'
8182       include 'COMMON.CONTACTS'
8183       include 'COMMON.TORSION'
8184       include 'COMMON.VAR'
8185       include 'COMMON.GEO'
8186       logical swap
8187       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8188      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8189       logical lprn
8190       common /kutas/ lprn
8191 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8192 C                                                                              C
8193 C      Parallel       Antiparallel                                             C
8194 C                                                                              C
8195 C          o             o                                                     C
8196 C     \   /l\           /j\   /                                                C
8197 C      \ /   \         /   \ /                                                 C
8198 C       o| o |         | o |o                                                  C
8199 C     \ j|/k\|      \  |/k\|l                                                  C
8200 C      \ /   \       \ /   \                                                   C
8201 C       o             o                                                        C
8202 C       i             i                                                        C
8203 C                                                                              C
8204 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8205 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8206 C AL 7/4/01 s1 would occur in the sixth-order moment,
8207 C           but not in a cluster cumulant
8208 #ifdef MOMENT
8209       s1=dip(1,jj,i)*dip(1,kk,k)
8210 #endif
8211       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8212       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8213       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8214       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8215       call transpose2(EUg(1,1,k),auxmat(1,1))
8216       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8217       vv(1)=pizda(1,1)-pizda(2,2)
8218       vv(2)=pizda(1,2)+pizda(2,1)
8219       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8220 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8221 #ifdef MOMENT
8222       eello6_graph2=-(s1+s2+s3+s4)
8223 #else
8224       eello6_graph2=-(s2+s3+s4)
8225 #endif
8226 c      eello6_graph2=-s3
8227       if (.not. calc_grad) return
8228 C Derivatives in gamma(i-1)
8229       if (i.gt.1) then
8230 #ifdef MOMENT
8231         s1=dipderg(1,jj,i)*dip(1,kk,k)
8232 #endif
8233         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8234         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8235         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8236         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8237 #ifdef MOMENT
8238         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8239 #else
8240         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8241 #endif
8242 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8243       endif
8244 C Derivatives in gamma(k-1)
8245 #ifdef MOMENT
8246       s1=dip(1,jj,i)*dipderg(1,kk,k)
8247 #endif
8248       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8249       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8250       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8251       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8252       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8253       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8254       vv(1)=pizda(1,1)-pizda(2,2)
8255       vv(2)=pizda(1,2)+pizda(2,1)
8256       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8257 #ifdef MOMENT
8258       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8259 #else
8260       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8261 #endif
8262 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8263 C Derivatives in gamma(j-1) or gamma(l-1)
8264       if (j.gt.1) then
8265 #ifdef MOMENT
8266         s1=dipderg(3,jj,i)*dip(1,kk,k)
8267 #endif
8268         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8269         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8270         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8271         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8272         vv(1)=pizda(1,1)-pizda(2,2)
8273         vv(2)=pizda(1,2)+pizda(2,1)
8274         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8275 #ifdef MOMENT
8276         if (swap) then
8277           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8278         else
8279           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8280         endif
8281 #endif
8282         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8283 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8284       endif
8285 C Derivatives in gamma(l-1) or gamma(j-1)
8286       if (l.gt.1) then
8287 #ifdef MOMENT
8288         s1=dip(1,jj,i)*dipderg(3,kk,k)
8289 #endif
8290         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8291         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8292         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8293         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8294         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8295         vv(1)=pizda(1,1)-pizda(2,2)
8296         vv(2)=pizda(1,2)+pizda(2,1)
8297         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8298 #ifdef MOMENT
8299         if (swap) then
8300           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8301         else
8302           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8303         endif
8304 #endif
8305         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8306 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8307       endif
8308 C Cartesian derivatives.
8309       if (lprn) then
8310         write (2,*) 'In eello6_graph2'
8311         do iii=1,2
8312           write (2,*) 'iii=',iii
8313           do kkk=1,5
8314             write (2,*) 'kkk=',kkk
8315             do jjj=1,2
8316               write (2,'(3(2f10.5),5x)')
8317      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8318             enddo
8319           enddo
8320         enddo
8321       endif
8322       do iii=1,2
8323         do kkk=1,5
8324           do lll=1,3
8325 #ifdef MOMENT
8326             if (iii.eq.1) then
8327               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8328             else
8329               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8330             endif
8331 #endif
8332             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8333      &        auxvec(1))
8334             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8335             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8336      &        auxvec(1))
8337             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8338             call transpose2(EUg(1,1,k),auxmat(1,1))
8339             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8340      &        pizda(1,1))
8341             vv(1)=pizda(1,1)-pizda(2,2)
8342             vv(2)=pizda(1,2)+pizda(2,1)
8343             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8344 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8345 #ifdef MOMENT
8346             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8347 #else
8348             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8349 #endif
8350             if (swap) then
8351               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8352             else
8353               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8354             endif
8355           enddo
8356         enddo
8357       enddo
8358       return
8359       end
8360 c----------------------------------------------------------------------------
8361       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8362       implicit real*8 (a-h,o-z)
8363       include 'DIMENSIONS'
8364       include 'DIMENSIONS.ZSCOPT'
8365       include 'COMMON.IOUNITS'
8366       include 'COMMON.CHAIN'
8367       include 'COMMON.DERIV'
8368       include 'COMMON.INTERACT'
8369       include 'COMMON.CONTACTS'
8370       include 'COMMON.TORSION'
8371       include 'COMMON.VAR'
8372       include 'COMMON.GEO'
8373       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8374       logical swap
8375 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8376 C                                                                              C
8377 C      Parallel       Antiparallel                                             C
8378 C                                                                              C
8379 C          o             o                                                     C
8380 C         /l\   /   \   /j\                                                    C
8381 C        /   \ /     \ /   \                                                   C
8382 C       /| o |o       o| o |\                                                  C
8383 C       j|/k\|  /      |/k\|l /                                                C
8384 C        /   \ /       /   \ /                                                 C
8385 C       /     o       /     o                                                  C
8386 C       i             i                                                        C
8387 C                                                                              C
8388 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8389 C
8390 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8391 C           energy moment and not to the cluster cumulant.
8392       iti=itortyp(itype(i))
8393       if (j.lt.nres-1) then
8394         itj1=itortyp(itype(j+1))
8395       else
8396         itj1=ntortyp+1
8397       endif
8398       itk=itortyp(itype(k))
8399       itk1=itortyp(itype(k+1))
8400       if (l.lt.nres-1) then
8401         itl1=itortyp(itype(l+1))
8402       else
8403         itl1=ntortyp+1
8404       endif
8405 #ifdef MOMENT
8406       s1=dip(4,jj,i)*dip(4,kk,k)
8407 #endif
8408       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8409       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8410       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8411       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8412       call transpose2(EE(1,1,itk),auxmat(1,1))
8413       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8414       vv(1)=pizda(1,1)+pizda(2,2)
8415       vv(2)=pizda(2,1)-pizda(1,2)
8416       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8417 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8418 #ifdef MOMENT
8419       eello6_graph3=-(s1+s2+s3+s4)
8420 #else
8421       eello6_graph3=-(s2+s3+s4)
8422 #endif
8423 c      eello6_graph3=-s4
8424       if (.not. calc_grad) return
8425 C Derivatives in gamma(k-1)
8426       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8427       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8428       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8429       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8430 C Derivatives in gamma(l-1)
8431       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8432       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8433       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8434       vv(1)=pizda(1,1)+pizda(2,2)
8435       vv(2)=pizda(2,1)-pizda(1,2)
8436       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8437       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8438 C Cartesian derivatives.
8439       do iii=1,2
8440         do kkk=1,5
8441           do lll=1,3
8442 #ifdef MOMENT
8443             if (iii.eq.1) then
8444               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8445             else
8446               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8447             endif
8448 #endif
8449             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8450      &        auxvec(1))
8451             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8452             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8453      &        auxvec(1))
8454             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8455             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8456      &        pizda(1,1))
8457             vv(1)=pizda(1,1)+pizda(2,2)
8458             vv(2)=pizda(2,1)-pizda(1,2)
8459             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8460 #ifdef MOMENT
8461             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8462 #else
8463             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8464 #endif
8465             if (swap) then
8466               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8467             else
8468               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8469             endif
8470 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8471           enddo
8472         enddo
8473       enddo
8474       return
8475       end
8476 c----------------------------------------------------------------------------
8477       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8478       implicit real*8 (a-h,o-z)
8479       include 'DIMENSIONS'
8480       include 'DIMENSIONS.ZSCOPT'
8481       include 'COMMON.IOUNITS'
8482       include 'COMMON.CHAIN'
8483       include 'COMMON.DERIV'
8484       include 'COMMON.INTERACT'
8485       include 'COMMON.CONTACTS'
8486       include 'COMMON.TORSION'
8487       include 'COMMON.VAR'
8488       include 'COMMON.GEO'
8489       include 'COMMON.FFIELD'
8490       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8491      & auxvec1(2),auxmat1(2,2)
8492       logical swap
8493 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8494 C                                                                              C
8495 C      Parallel       Antiparallel                                             C
8496 C                                                                              C
8497 C          o             o                                                     C
8498 C         /l\   /   \   /j\                                                    C
8499 C        /   \ /     \ /   \                                                   C
8500 C       /| o |o       o| o |\                                                  C
8501 C     \ j|/k\|      \  |/k\|l                                                  C
8502 C      \ /   \       \ /   \                                                   C
8503 C       o     \       o     \                                                  C
8504 C       i             i                                                        C
8505 C                                                                              C
8506 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8507 C
8508 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8509 C           energy moment and not to the cluster cumulant.
8510 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8511       iti=itortyp(itype(i))
8512       itj=itortyp(itype(j))
8513       if (j.lt.nres-1) then
8514         itj1=itortyp(itype(j+1))
8515       else
8516         itj1=ntortyp+1
8517       endif
8518       itk=itortyp(itype(k))
8519       if (k.lt.nres-1) then
8520         itk1=itortyp(itype(k+1))
8521       else
8522         itk1=ntortyp+1
8523       endif
8524       itl=itortyp(itype(l))
8525       if (l.lt.nres-1) then
8526         itl1=itortyp(itype(l+1))
8527       else
8528         itl1=ntortyp+1
8529       endif
8530 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8531 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8532 cd     & ' itl',itl,' itl1',itl1
8533 #ifdef MOMENT
8534       if (imat.eq.1) then
8535         s1=dip(3,jj,i)*dip(3,kk,k)
8536       else
8537         s1=dip(2,jj,j)*dip(2,kk,l)
8538       endif
8539 #endif
8540       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8541       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8542       if (j.eq.l+1) then
8543         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8544         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8545       else
8546         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8547         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8548       endif
8549       call transpose2(EUg(1,1,k),auxmat(1,1))
8550       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8551       vv(1)=pizda(1,1)-pizda(2,2)
8552       vv(2)=pizda(2,1)+pizda(1,2)
8553       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8554 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8555 #ifdef MOMENT
8556       eello6_graph4=-(s1+s2+s3+s4)
8557 #else
8558       eello6_graph4=-(s2+s3+s4)
8559 #endif
8560       if (.not. calc_grad) return
8561 C Derivatives in gamma(i-1)
8562       if (i.gt.1) then
8563 #ifdef MOMENT
8564         if (imat.eq.1) then
8565           s1=dipderg(2,jj,i)*dip(3,kk,k)
8566         else
8567           s1=dipderg(4,jj,j)*dip(2,kk,l)
8568         endif
8569 #endif
8570         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8571         if (j.eq.l+1) then
8572           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8573           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8574         else
8575           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8576           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8577         endif
8578         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8579         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8580 cd          write (2,*) 'turn6 derivatives'
8581 #ifdef MOMENT
8582           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8583 #else
8584           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8585 #endif
8586         else
8587 #ifdef MOMENT
8588           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8589 #else
8590           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8591 #endif
8592         endif
8593       endif
8594 C Derivatives in gamma(k-1)
8595 #ifdef MOMENT
8596       if (imat.eq.1) then
8597         s1=dip(3,jj,i)*dipderg(2,kk,k)
8598       else
8599         s1=dip(2,jj,j)*dipderg(4,kk,l)
8600       endif
8601 #endif
8602       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8603       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8604       if (j.eq.l+1) then
8605         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8606         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8607       else
8608         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8609         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8610       endif
8611       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8612       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8613       vv(1)=pizda(1,1)-pizda(2,2)
8614       vv(2)=pizda(2,1)+pizda(1,2)
8615       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8616       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8617 #ifdef MOMENT
8618         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8619 #else
8620         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8621 #endif
8622       else
8623 #ifdef MOMENT
8624         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8625 #else
8626         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8627 #endif
8628       endif
8629 C Derivatives in gamma(j-1) or gamma(l-1)
8630       if (l.eq.j+1 .and. l.gt.1) then
8631         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8632         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8633         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8634         vv(1)=pizda(1,1)-pizda(2,2)
8635         vv(2)=pizda(2,1)+pizda(1,2)
8636         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8637         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8638       else if (j.gt.1) then
8639         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8640         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8641         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8642         vv(1)=pizda(1,1)-pizda(2,2)
8643         vv(2)=pizda(2,1)+pizda(1,2)
8644         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8645         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8646           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8647         else
8648           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8649         endif
8650       endif
8651 C Cartesian derivatives.
8652       do iii=1,2
8653         do kkk=1,5
8654           do lll=1,3
8655 #ifdef MOMENT
8656             if (iii.eq.1) then
8657               if (imat.eq.1) then
8658                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8659               else
8660                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8661               endif
8662             else
8663               if (imat.eq.1) then
8664                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8665               else
8666                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8667               endif
8668             endif
8669 #endif
8670             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8671      &        auxvec(1))
8672             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8673             if (j.eq.l+1) then
8674               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8675      &          b1(1,itj1),auxvec(1))
8676               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8677             else
8678               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8679      &          b1(1,itl1),auxvec(1))
8680               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8681             endif
8682             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8683      &        pizda(1,1))
8684             vv(1)=pizda(1,1)-pizda(2,2)
8685             vv(2)=pizda(2,1)+pizda(1,2)
8686             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8687             if (swap) then
8688               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8689 #ifdef MOMENT
8690                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8691      &             -(s1+s2+s4)
8692 #else
8693                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8694      &             -(s2+s4)
8695 #endif
8696                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8697               else
8698 #ifdef MOMENT
8699                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8700 #else
8701                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8702 #endif
8703                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8704               endif
8705             else
8706 #ifdef MOMENT
8707               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8708 #else
8709               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8710 #endif
8711               if (l.eq.j+1) then
8712                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8713               else
8714                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8715               endif
8716             endif
8717           enddo
8718         enddo
8719       enddo
8720       return
8721       end
8722 c----------------------------------------------------------------------------
8723       double precision function eello_turn6(i,jj,kk)
8724       implicit real*8 (a-h,o-z)
8725       include 'DIMENSIONS'
8726       include 'DIMENSIONS.ZSCOPT'
8727       include 'COMMON.IOUNITS'
8728       include 'COMMON.CHAIN'
8729       include 'COMMON.DERIV'
8730       include 'COMMON.INTERACT'
8731       include 'COMMON.CONTACTS'
8732       include 'COMMON.TORSION'
8733       include 'COMMON.VAR'
8734       include 'COMMON.GEO'
8735       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8736      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8737      &  ggg1(3),ggg2(3)
8738       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8739      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8740 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8741 C           the respective energy moment and not to the cluster cumulant.
8742       eello_turn6=0.0d0
8743       j=i+4
8744       k=i+1
8745       l=i+3
8746       iti=itortyp(itype(i))
8747       itk=itortyp(itype(k))
8748       itk1=itortyp(itype(k+1))
8749       itl=itortyp(itype(l))
8750       itj=itortyp(itype(j))
8751 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8752 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8753 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8754 cd        eello6=0.0d0
8755 cd        return
8756 cd      endif
8757 cd      write (iout,*)
8758 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8759 cd     &   ' and',k,l
8760 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8761       do iii=1,2
8762         do kkk=1,5
8763           do lll=1,3
8764             derx_turn(lll,kkk,iii)=0.0d0
8765           enddo
8766         enddo
8767       enddo
8768 cd      eij=1.0d0
8769 cd      ekl=1.0d0
8770 cd      ekont=1.0d0
8771       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8772 cd      eello6_5=0.0d0
8773 cd      write (2,*) 'eello6_5',eello6_5
8774 #ifdef MOMENT
8775       call transpose2(AEA(1,1,1),auxmat(1,1))
8776       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8777       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8778       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8779 #else
8780       s1 = 0.0d0
8781 #endif
8782       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8783       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8784       s2 = scalar2(b1(1,itk),vtemp1(1))
8785 #ifdef MOMENT
8786       call transpose2(AEA(1,1,2),atemp(1,1))
8787       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8788       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8789       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8790 #else
8791       s8=0.0d0
8792 #endif
8793       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8794       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8795       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8796 #ifdef MOMENT
8797       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8798       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8799       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8800       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8801       ss13 = scalar2(b1(1,itk),vtemp4(1))
8802       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8803 #else
8804       s13=0.0d0
8805 #endif
8806 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8807 c      s1=0.0d0
8808 c      s2=0.0d0
8809 c      s8=0.0d0
8810 c      s12=0.0d0
8811 c      s13=0.0d0
8812       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8813       if (calc_grad) then
8814 C Derivatives in gamma(i+2)
8815 #ifdef MOMENT
8816       call transpose2(AEA(1,1,1),auxmatd(1,1))
8817       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8818       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8819       call transpose2(AEAderg(1,1,2),atempd(1,1))
8820       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8821       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8822 #else
8823       s8d=0.0d0
8824 #endif
8825       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8826       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8827       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8828 c      s1d=0.0d0
8829 c      s2d=0.0d0
8830 c      s8d=0.0d0
8831 c      s12d=0.0d0
8832 c      s13d=0.0d0
8833       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8834 C Derivatives in gamma(i+3)
8835 #ifdef MOMENT
8836       call transpose2(AEA(1,1,1),auxmatd(1,1))
8837       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8838       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8839       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8840 #else
8841       s1d=0.0d0
8842 #endif
8843       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8844       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8845       s2d = scalar2(b1(1,itk),vtemp1d(1))
8846 #ifdef MOMENT
8847       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8848       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8849 #endif
8850       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8851 #ifdef MOMENT
8852       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8853       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8854       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8855 #else
8856       s13d=0.0d0
8857 #endif
8858 c      s1d=0.0d0
8859 c      s2d=0.0d0
8860 c      s8d=0.0d0
8861 c      s12d=0.0d0
8862 c      s13d=0.0d0
8863 #ifdef MOMENT
8864       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8865      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8866 #else
8867       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8868      &               -0.5d0*ekont*(s2d+s12d)
8869 #endif
8870 C Derivatives in gamma(i+4)
8871       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8872       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8873       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8874 #ifdef MOMENT
8875       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8876       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8877       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8878 #else
8879       s13d = 0.0d0
8880 #endif
8881 c      s1d=0.0d0
8882 c      s2d=0.0d0
8883 c      s8d=0.0d0
8884 C      s12d=0.0d0
8885 c      s13d=0.0d0
8886 #ifdef MOMENT
8887       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8888 #else
8889       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8890 #endif
8891 C Derivatives in gamma(i+5)
8892 #ifdef MOMENT
8893       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8894       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8895       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8896 #else
8897       s1d = 0.0d0
8898 #endif
8899       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8900       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8901       s2d = scalar2(b1(1,itk),vtemp1d(1))
8902 #ifdef MOMENT
8903       call transpose2(AEA(1,1,2),atempd(1,1))
8904       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8905       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8906 #else
8907       s8d = 0.0d0
8908 #endif
8909       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8910       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8911 #ifdef MOMENT
8912       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8913       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8914       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8915 #else
8916       s13d = 0.0d0
8917 #endif
8918 c      s1d=0.0d0
8919 c      s2d=0.0d0
8920 c      s8d=0.0d0
8921 c      s12d=0.0d0
8922 c      s13d=0.0d0
8923 #ifdef MOMENT
8924       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8925      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8926 #else
8927       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8928      &               -0.5d0*ekont*(s2d+s12d)
8929 #endif
8930 C Cartesian derivatives
8931       do iii=1,2
8932         do kkk=1,5
8933           do lll=1,3
8934 #ifdef MOMENT
8935             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8936             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8937             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8938 #else
8939             s1d = 0.0d0
8940 #endif
8941             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8942             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8943      &          vtemp1d(1))
8944             s2d = scalar2(b1(1,itk),vtemp1d(1))
8945 #ifdef MOMENT
8946             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8947             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8948             s8d = -(atempd(1,1)+atempd(2,2))*
8949      &           scalar2(cc(1,1,itl),vtemp2(1))
8950 #else
8951             s8d = 0.0d0
8952 #endif
8953             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8954      &           auxmatd(1,1))
8955             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8956             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8957 c      s1d=0.0d0
8958 c      s2d=0.0d0
8959 c      s8d=0.0d0
8960 c      s12d=0.0d0
8961 c      s13d=0.0d0
8962 #ifdef MOMENT
8963             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8964      &        - 0.5d0*(s1d+s2d)
8965 #else
8966             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8967      &        - 0.5d0*s2d
8968 #endif
8969 #ifdef MOMENT
8970             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8971      &        - 0.5d0*(s8d+s12d)
8972 #else
8973             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8974      &        - 0.5d0*s12d
8975 #endif
8976           enddo
8977         enddo
8978       enddo
8979 #ifdef MOMENT
8980       do kkk=1,5
8981         do lll=1,3
8982           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8983      &      achuj_tempd(1,1))
8984           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8985           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8986           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8987           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8988           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8989      &      vtemp4d(1))
8990           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8991           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8992           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8993         enddo
8994       enddo
8995 #endif
8996 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8997 cd     &  16*eel_turn6_num
8998 cd      goto 1112
8999       if (j.lt.nres-1) then
9000         j1=j+1
9001         j2=j-1
9002       else
9003         j1=j-1
9004         j2=j-2
9005       endif
9006       if (l.lt.nres-1) then
9007         l1=l+1
9008         l2=l-1
9009       else
9010         l1=l-1
9011         l2=l-2
9012       endif
9013       do ll=1,3
9014         ggg1(ll)=eel_turn6*g_contij(ll,1)
9015         ggg2(ll)=eel_turn6*g_contij(ll,2)
9016         ghalf=0.5d0*ggg1(ll)
9017 cd        ghalf=0.0d0
9018         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
9019      &    +ekont*derx_turn(ll,2,1)
9020         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9021         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
9022      &    +ekont*derx_turn(ll,4,1)
9023         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9024         ghalf=0.5d0*ggg2(ll)
9025 cd        ghalf=0.0d0
9026         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
9027      &    +ekont*derx_turn(ll,2,2)
9028         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9029         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
9030      &    +ekont*derx_turn(ll,4,2)
9031         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9032       enddo
9033 cd      goto 1112
9034       do m=i+1,j-1
9035         do ll=1,3
9036           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9037         enddo
9038       enddo
9039       do m=k+1,l-1
9040         do ll=1,3
9041           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9042         enddo
9043       enddo
9044 1112  continue
9045       do m=i+2,j2
9046         do ll=1,3
9047           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9048         enddo
9049       enddo
9050       do m=k+2,l2
9051         do ll=1,3
9052           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9053         enddo
9054       enddo
9055 cd      do iii=1,nres-3
9056 cd        write (2,*) iii,g_corr6_loc(iii)
9057 cd      enddo
9058       endif
9059       eello_turn6=ekont*eel_turn6
9060 cd      write (2,*) 'ekont',ekont
9061 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9062       return
9063       end
9064 crc-------------------------------------------------
9065       SUBROUTINE MATVEC2(A1,V1,V2)
9066       implicit real*8 (a-h,o-z)
9067       include 'DIMENSIONS'
9068       DIMENSION A1(2,2),V1(2),V2(2)
9069 c      DO 1 I=1,2
9070 c        VI=0.0
9071 c        DO 3 K=1,2
9072 c    3     VI=VI+A1(I,K)*V1(K)
9073 c        Vaux(I)=VI
9074 c    1 CONTINUE
9075
9076       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9077       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9078
9079       v2(1)=vaux1
9080       v2(2)=vaux2
9081       END
9082 C---------------------------------------
9083       SUBROUTINE MATMAT2(A1,A2,A3)
9084       implicit real*8 (a-h,o-z)
9085       include 'DIMENSIONS'
9086       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9087 c      DIMENSION AI3(2,2)
9088 c        DO  J=1,2
9089 c          A3IJ=0.0
9090 c          DO K=1,2
9091 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9092 c          enddo
9093 c          A3(I,J)=A3IJ
9094 c       enddo
9095 c      enddo
9096
9097       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9098       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9099       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9100       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9101
9102       A3(1,1)=AI3_11
9103       A3(2,1)=AI3_21
9104       A3(1,2)=AI3_12
9105       A3(2,2)=AI3_22
9106       END
9107
9108 c-------------------------------------------------------------------------
9109       double precision function scalar2(u,v)
9110       implicit none
9111       double precision u(2),v(2)
9112       double precision sc
9113       integer i
9114       scalar2=u(1)*v(1)+u(2)*v(2)
9115       return
9116       end
9117
9118 C-----------------------------------------------------------------------------
9119
9120       subroutine transpose2(a,at)
9121       implicit none
9122       double precision a(2,2),at(2,2)
9123       at(1,1)=a(1,1)
9124       at(1,2)=a(2,1)
9125       at(2,1)=a(1,2)
9126       at(2,2)=a(2,2)
9127       return
9128       end
9129 c--------------------------------------------------------------------------
9130       subroutine transpose(n,a,at)
9131       implicit none
9132       integer n,i,j
9133       double precision a(n,n),at(n,n)
9134       do i=1,n
9135         do j=1,n
9136           at(j,i)=a(i,j)
9137         enddo
9138       enddo
9139       return
9140       end
9141 C---------------------------------------------------------------------------
9142       subroutine prodmat3(a1,a2,kk,transp,prod)
9143       implicit none
9144       integer i,j
9145       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9146       logical transp
9147 crc      double precision auxmat(2,2),prod_(2,2)
9148
9149       if (transp) then
9150 crc        call transpose2(kk(1,1),auxmat(1,1))
9151 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9152 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9153
9154            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9155      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9156            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9157      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9158            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9159      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9160            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9161      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9162
9163       else
9164 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9165 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9166
9167            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9168      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9169            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9170      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9171            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9172      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9173            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9174      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9175
9176       endif
9177 c      call transpose2(a2(1,1),a2t(1,1))
9178
9179 crc      print *,transp
9180 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9181 crc      print *,((prod(i,j),i=1,2),j=1,2)
9182
9183       return
9184       end
9185 C-----------------------------------------------------------------------------
9186       double precision function scalar(u,v)
9187       implicit none
9188       double precision u(3),v(3)
9189       double precision sc
9190       integer i
9191       sc=0.0d0
9192       do i=1,3
9193         sc=sc+u(i)*v(i)
9194       enddo
9195       scalar=sc
9196       return
9197       end
9198