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        energy_dec=.false.
1075        IF (energy_dec) write (iout,'(a)')
1076      & ' AAi i  AAj  j  1/rij  Rtail   Rhead   evdwij   Fcav   Ecl
1077      & Egb   Epol   Fisocav   Elj   Equad   evdw'
1078        evdw   = 0.0D0
1079        evdw_p = 0.0D0
1080        evdw_m = 0.0D0
1081 c DIAGNOSTICS
1082 ccccc      energy_dec=.false.
1083 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1084 c      lprn   = .false.
1085 c     if (icall.eq.0) lprn=.false.
1086 c END DIAGNOSTICS
1087 c      ind = 0
1088        DO i = iatsc_s, iatsc_e
1089         itypi  = itype(i)
1090 c        itypi1 = itype(i+1)
1091         dxi    = dc_norm(1,nres+i)
1092         dyi    = dc_norm(2,nres+i)
1093         dzi    = dc_norm(3,nres+i)
1094 c        dsci_inv=dsc_inv(itypi)
1095         dsci_inv = vbld_inv(i+nres)
1096 c        DO k = 1, 3
1097 c         ctail(k,1) = c(k, i+nres)
1098 c     &              - dtail(1,itypi,itypj) * dc_norm(k, nres+i)
1099 c        END DO
1100         xi=c(1,nres+i)
1101         yi=c(2,nres+i)
1102         zi=c(3,nres+i)
1103 c!-------------------------------------------------------------------
1104 C Calculate SC interaction energy.
1105         DO iint = 1, nint_gr(i)
1106          DO j = istart(i,iint), iend(i,iint)
1107 c! initialize variables for electrostatic gradients
1108           CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
1109 c            ind=ind+1
1110 c            dscj_inv = dsc_inv(itypj)
1111           dscj_inv = vbld_inv(j+nres)
1112 c! rij holds 1/(distance of Calpha atoms)
1113           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
1114           rij  = dsqrt(rrij)
1115 c!-------------------------------------------------------------------
1116 C Calculate angle-dependent terms of energy and contributions to their
1117 C derivatives.
1118
1119 #IFDEF CHECK_MOMO
1120 c!      DO troll = 10, 5000
1121 c!      om1    = 0.0d0
1122 c!      om2    = 0.0d0
1123 c!      om12   = 1.0d0
1124 c!      sqom1  = om1 * om1
1125 c!      sqom2  = om2 * om2
1126 c!      sqom12 = om12 * om12
1127 c!      rij    = 5.0d0 / troll
1128 c!      rrij   = rij * rij
1129 c!      Rtail  = troll / 5.0d0
1130 c!      Rhead  = troll / 5.0d0
1131 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1132 c!      Rtail = dsqrt((Rtail**2)
1133 c!     &      +((dabs(dtail(1,itypi,itypj)-dtail(2,itypi,itypj)))**2))
1134 c!      rij = 1.0d0/Rtail
1135 c!      rrij = rij * rij
1136 #ENDIF
1137           CALL sc_angular
1138 c! this should be in elgrad_init but om's are calculated by sc_angular
1139 c! which in turn is used by older potentials
1140 c! which proves how tangled UNRES code is >.<
1141 c! om = omega, sqom = om^2
1142           sqom1  = om1 * om1
1143           sqom2  = om2 * om2
1144           sqom12 = om12 * om12
1145
1146 c! now we calculate EGB - Gey-Berne
1147 c! It will be summed up in evdwij and saved in evdw
1148           sigsq     = 1.0D0  / sigsq
1149           sig       = sig0ij * dsqrt(sigsq)
1150 c!          rij_shift = 1.0D0  / rij - sig + sig0ij
1151           rij_shift = Rtail - sig + sig0ij
1152 c          write (2,*) "Rtal",Rtail," sig",sig," sigsq",sigsq,
1153 c     &       " sig0ij",sig0ij
1154 c          write (2,*) "rij_shift",rij_shift
1155           IF (rij_shift.le.0.0D0) THEN
1156            evdw = 1.0D20
1157            RETURN
1158           END IF
1159           sigder = -sig * sigsq
1160           rij_shift = 1.0D0 / rij_shift
1161           fac       = rij_shift**expon
1162           c1        = fac  * fac * aa(itypi,itypj)
1163 c!          c1        = 0.0d0
1164           c2        = fac  * bb(itypi,itypj)
1165 c!          c2        = 0.0d0
1166 c          write (2,*) "eps1",eps1," eps2rt",eps2rt," eps3rt",eps3rt,
1167 c     &     " c1",c1," c2",c2
1168           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
1169           eps2der   = eps3rt * evdwij
1170           eps3der   = eps2rt * evdwij
1171 c!          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
1172           evdwij    = eps2rt * eps3rt * evdwij
1173 c!      evdwij = 0.0d0
1174 c!      write (*,*) "Gey Berne = ", evdwij
1175 #ifdef TSCSC
1176           IF (bb(itypi,itypj).gt.0) THEN
1177            evdw_p = evdw_p + evdwij
1178           ELSE
1179            evdw_m = evdw_m + evdwij
1180           END IF
1181 #else
1182           evdw = evdw
1183      &         + evdwij
1184 #endif
1185 c!-------------------------------------------------------------------
1186 c! Calculate some components of GGB
1187           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
1188           fac    = -expon * (c1 + evdwij) * rij_shift
1189           sigder = fac * sigder
1190 c!          fac    = rij * fac
1191 c! Calculate distance derivative
1192 c!          gg(1) = xj * fac
1193 c!          gg(2) = yj * fac
1194 c!          gg(3) = zj * fac
1195           gg(1) = fac
1196           gg(2) = fac
1197           gg(3) = fac
1198 c!      write (*,*) "gg(1) = ", gg(1)
1199 c!      write (*,*) "gg(2) = ", gg(2)
1200 c!      write (*,*) "gg(3) = ", gg(3)
1201 c! The angular derivatives of GGB are brought together in sc_grad
1202 c!-------------------------------------------------------------------
1203 c! Fcav
1204 c!
1205 c! Catch gly-gly interactions to skip calculation of something that
1206 c! does not exist
1207
1208       IF (itypi.eq.10.and.itypj.eq.10) THEN
1209        Fcav = 0.0d0
1210        dFdR = 0.0d0
1211        dCAVdOM1  = 0.0d0
1212        dCAVdOM2  = 0.0d0
1213        dCAVdOM12 = 0.0d0
1214       ELSE
1215
1216 c! we are not 2 glycines, so we calculate Fcav (and maybe more)
1217        fac = chis1 * sqom1 + chis2 * sqom2
1218      &     - 2.0d0 * chis12 * om1 * om2 * om12
1219 c! we will use pom later in Gcav, so dont mess with it!
1220        pom = 1.0d0 - chis1 * chis2 * sqom12
1221
1222        Lambf = (1.0d0 - (fac / pom))
1223        Lambf = dsqrt(Lambf)
1224
1225
1226        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
1227 c!       write (*,*) "sparrow = ", sparrow
1228        Chif = Rtail * sparrow
1229        ChiLambf = Chif * Lambf
1230        eagle = dsqrt(ChiLambf)
1231        bat = ChiLambf ** 11.0d0
1232
1233        top = b1 * ( eagle + b2 * ChiLambf - b3 )
1234        bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
1235        botsq = bot * bot
1236
1237 c!      write (*,*) "sig1 = ",sig1
1238 c!      write (*,*) "sig2 = ",sig2
1239 c!      write (*,*) "Rtail = ",Rtail
1240 c!      write (*,*) "sparrow = ",sparrow
1241 c!      write (*,*) "Chis1 = ", chis1
1242 c!      write (*,*) "Chis2 = ", chis2
1243 c!      write (*,*) "Chis12 = ", chis12
1244 c!      write (*,*) "om1 = ", om1
1245 c!      write (*,*) "om2 = ", om2
1246 c!      write (*,*) "om12 = ", om12
1247 c!      write (*,*) "sqom1 = ", sqom1
1248 c!      write (*,*) "sqom2 = ", sqom2
1249 c!      write (*,*) "sqom12 = ", sqom12
1250 c!      write (*,*) "Lambf = ",Lambf
1251 c!      write (*,*) "b1 = ",b1
1252 c!      write (*,*) "b2 = ",b2
1253 c!      write (*,*) "b3 = ",b3
1254 c!      write (*,*) "b4 = ",b4
1255 c!      write (*,*) "top = ",top
1256 c!      write (*,*) "bot = ",bot
1257        Fcav = top / bot
1258 c!       Fcav = 0.0d0
1259 c!      write (*,*) "Fcav = ", Fcav
1260 c!-------------------------------------------------------------------
1261 c! derivative of Fcav is Gcav...
1262 c!---------------------------------------------------
1263
1264        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
1265        dbot = 12.0d0 * b4 * bat * Lambf
1266        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
1267 c!       dFdR = 0.0d0
1268 c!      write (*,*) "dFcav/dR = ", dFdR
1269
1270        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
1271        dbot = 12.0d0 * b4 * bat * Chif
1272        eagle = Lambf * pom
1273        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
1274        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
1275        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)
1276      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)
1277
1278        dFdL = ((dtop * bot - top * dbot) / botsq)
1279 c!       dFdL = 0.0d0
1280        dCAVdOM1  = dFdL * ( dFdOM1 )
1281        dCAVdOM2  = dFdL * ( dFdOM2 )
1282        dCAVdOM12 = dFdL * ( dFdOM12 )
1283 c!      write (*,*) "dFcav/dOM1 = ", dCAVdOM1
1284 c!      write (*,*) "dFcav/dOM2 = ", dCAVdOM2
1285 c!      write (*,*) "dFcav/dOM12 = ", dCAVdOM12
1286 c!      write (*,*) ""
1287 c!-------------------------------------------------------------------
1288 c! Finally, add the distance derivatives of GB and Fcav to gvdwc
1289 c! Pom is used here to project the gradient vector into
1290 c! cartesian coordinates and at the same time contains
1291 c! dXhb/dXsc derivative (for charged amino acids
1292 c! location of hydrophobic centre of interaction is not
1293 c! the same as geometric centre of side chain, this
1294 c! derivative takes that into account)
1295 c! derivatives of omega angles will be added in sc_grad
1296
1297        DO k= 1, 3
1298         ertail(k) = Rtail_distance(k)/Rtail
1299        END DO
1300        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
1301        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
1302        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1303        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1304        DO k = 1, 3
1305 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1306 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1307         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
1308         gvdwx(k,i) = gvdwx(k,i)
1309      &             - (( dFdR + gg(k) ) * pom)
1310 c!     &             - ( dFdR * pom )
1311         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
1312         gvdwx(k,j) = gvdwx(k,j)
1313      &             + (( dFdR + gg(k) ) * pom)
1314 c!     &             + ( dFdR * pom )
1315
1316         gvdwc(k,i) = gvdwc(k,i)
1317      &             - (( dFdR + gg(k) ) * ertail(k))
1318 c!     &             - ( dFdR * ertail(k))
1319
1320         gvdwc(k,j) = gvdwc(k,j)
1321      &             + (( dFdR + gg(k) ) * ertail(k))
1322 c!     &             + ( dFdR * ertail(k))
1323
1324         gg(k) = 0.0d0
1325 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1326 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1327       END DO
1328
1329 c!-------------------------------------------------------------------
1330 c! Compute head-head and head-tail energies for each state
1331
1332           isel = iabs(Qi) + iabs(Qj)
1333           IF (isel.eq.0) THEN
1334 c! No charges - do nothing
1335            eheadtail = 0.0d0
1336
1337           ELSE IF (isel.eq.4) THEN
1338 c! Calculate dipole-dipole interactions
1339            CALL edd(ecl)
1340            eheadtail = ECL
1341
1342           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
1343 c! Charge-nonpolar interactions
1344            CALL eqn(epol)
1345            eheadtail = epol
1346
1347           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
1348 c! Nonpolar-charge interactions
1349            CALL enq(epol)
1350            eheadtail = epol
1351
1352           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
1353 c! Charge-dipole interactions
1354            CALL eqd(ecl, elj, epol)
1355            eheadtail = ECL + elj + epol
1356
1357           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
1358 c! Dipole-charge interactions
1359            CALL edq(ecl, elj, epol)
1360            eheadtail = ECL + elj + epol
1361
1362           ELSE IF ((isel.eq.2.and.
1363      &          iabs(Qi).eq.1).and.
1364      &          nstate(itypi,itypj).eq.1) THEN
1365 c! Same charge-charge interaction ( +/+ or -/- )
1366            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
1367            eheadtail = ECL + Egb + Epol + Fisocav + Elj
1368
1369           ELSE IF ((isel.eq.2.and.
1370      &          iabs(Qi).eq.1).and.
1371      &          nstate(itypi,itypj).ne.1) THEN
1372 c! Different charge-charge interaction ( +/- or -/+ )
1373            CALL energy_quad
1374      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1375           END IF
1376        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
1377 c!      write (*,*) "evdw = ", evdw
1378 c!      write (*,*) "Fcav = ", Fcav
1379 c!      write (*,*) "eheadtail = ", eheadtail
1380        evdw = evdw
1381      &      + Fcav
1382      &      + eheadtail
1383
1384        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,9f16.7)')
1385      &  restyp(itype(i)),i,restyp(itype(j)),j,
1386      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1387      &  Equad,evdw
1388        IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
1389      &  restyp(itype(i)),i,restyp(itype(j)),j,
1390      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1391      &  Equad,evdw
1392 #IFDEF CHECK_MOMO
1393        evdw = 0.0d0
1394        END DO ! troll
1395 #ENDIF
1396
1397 c!-------------------------------------------------------------------
1398 c! As all angular derivatives are done, now we sum them up,
1399 c! then transform and project into cartesian vectors and add to gvdwc
1400 c! We call sc_grad always, with the exception of +/- interaction.
1401 c! This is because energy_quad subroutine needs to handle
1402 c! this job in his own way.
1403 c! This IS probably not very efficient and SHOULD be optimised
1404 c! but it will require major restructurization of emomo
1405 c! so it will be left as it is for now
1406 c!       write (*,*) 'troll1, nstate =', nstate (itypi,itypj)
1407        IF (nstate(itypi,itypj).eq.1) THEN
1408 #ifdef TSCSC
1409         IF (bb(itypi,itypj).gt.0) THEN
1410          CALL sc_grad
1411         ELSE
1412          CALL sc_grad_T
1413         END IF
1414 #else
1415         CALL sc_grad
1416 #endif
1417        END IF
1418 c!-------------------------------------------------------------------
1419 c! NAPISY KONCOWE
1420          END DO   ! j
1421         END DO    ! iint
1422        END DO     ! i
1423 c      write (iout,*) "Number of loop steps in EGB:",ind
1424 c      energy_dec=.false.
1425        RETURN
1426       END SUBROUTINE emomo
1427 c! END OF MOMO
1428
1429
1430 C-----------------------------------------------------------------------------
1431
1432
1433       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
1434        IMPLICIT NONE
1435        INCLUDE 'DIMENSIONS'
1436        INCLUDE 'DIMENSIONS.ZSCOPT'
1437        INCLUDE 'COMMON.CALC'
1438        INCLUDE 'COMMON.CHAIN'
1439        INCLUDE 'COMMON.CONTROL'
1440        INCLUDE 'COMMON.DERIV'
1441        INCLUDE 'COMMON.EMP'
1442        INCLUDE 'COMMON.GEO'
1443        INCLUDE 'COMMON.INTERACT'
1444        INCLUDE 'COMMON.IOUNITS'
1445        INCLUDE 'COMMON.LOCAL'
1446        INCLUDE 'COMMON.NAMES'
1447        INCLUDE 'COMMON.VAR'
1448        double precision scalar, facd3, facd4, federmaus, adler
1449 c! Epol and Gpol analytical parameters
1450        alphapol1 = alphapol(itypi,itypj)
1451        alphapol2 = alphapol(itypj,itypi)
1452 c! Fisocav and Gisocav analytical parameters
1453        al1  = alphiso(1,itypi,itypj)
1454        al2  = alphiso(2,itypi,itypj)
1455        al3  = alphiso(3,itypi,itypj)
1456        al4  = alphiso(4,itypi,itypj)
1457        csig = (1.0d0
1458      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1459      &      + sigiso2(itypi,itypj)**2.0d0))
1460 c!
1461        pis  = sig0head(itypi,itypj)
1462        eps_head = epshead(itypi,itypj)
1463        Rhead_sq = Rhead * Rhead
1464 c! R1 - distance between head of ith side chain and tail of jth sidechain
1465 c! R2 - distance between head of jth side chain and tail of ith sidechain
1466        R1 = 0.0d0
1467        R2 = 0.0d0
1468        DO k = 1, 3
1469 c! Calculate head-to-tail distances needed by Epol
1470         R1=R1+(ctail(k,2)-chead(k,1))**2
1471         R2=R2+(chead(k,2)-ctail(k,1))**2
1472        END DO
1473 c! Pitagoras
1474        R1 = dsqrt(R1)
1475        R2 = dsqrt(R2)
1476
1477 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1478 c!     &        +dhead(1,1,itypi,itypj))**2))
1479 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1480 c!     &        +dhead(2,1,itypi,itypj))**2))
1481
1482 c!-------------------------------------------------------------------
1483 c! Coulomb electrostatic interaction
1484        Ecl = (332.0d0 * Qij) / Rhead
1485 c! derivative of Ecl is Gcl...
1486        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
1487        dGCLdOM1 = 0.0d0
1488        dGCLdOM2 = 0.0d0
1489        dGCLdOM12 = 0.0d0
1490 c!-------------------------------------------------------------------
1491 c! Generalised Born Solvent Polarization
1492 c! Charged head polarizes the solvent
1493        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1494        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1495        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1496 c! Derivative of Egb is Ggb...
1497        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1498        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1499      &        / ( 2.0d0 * Fgb )
1500        dGGBdR = dGGBdFGB * dFGBdR
1501 c!-------------------------------------------------------------------
1502 c! Fisocav - isotropic cavity creation term
1503 c! or "how much energy it costs to put charged head in water"
1504        pom = Rhead * csig
1505        top = al1 * (dsqrt(pom) + al2 * pom - al3)
1506        bot = (1.0d0 + al4 * pom**12.0d0)
1507        botsq = bot * bot
1508        FisoCav = top / bot
1509 c!      write (*,*) "Rhead = ",Rhead
1510 c!      write (*,*) "csig = ",csig
1511 c!      write (*,*) "pom = ",pom
1512 c!      write (*,*) "al1 = ",al1
1513 c!      write (*,*) "al2 = ",al2
1514 c!      write (*,*) "al3 = ",al3
1515 c!      write (*,*) "al4 = ",al4
1516 c!      write (*,*) "top = ",top
1517 c!      write (*,*) "bot = ",bot
1518 c! Derivative of Fisocav is GCV...
1519        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1520        dbot = 12.0d0 * al4 * pom ** 11.0d0
1521        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1522 c!-------------------------------------------------------------------
1523 c! Epol
1524 c! Polarization energy - charged heads polarize hydrophobic "neck"
1525        MomoFac1 = (1.0d0 - chi1 * sqom2)
1526        MomoFac2 = (1.0d0 - chi2 * sqom1)
1527        RR1  = ( R1 * R1 ) / MomoFac1
1528        RR2  = ( R2 * R2 ) / MomoFac2
1529        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1530        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1531        fgb1 = sqrt( RR1 + a12sq * ee1 )
1532        fgb2 = sqrt( RR2 + a12sq * ee2 )
1533        epol = 332.0d0 * eps_inout_fac * (
1534      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1535 c!       epol = 0.0d0
1536 c       write (*,*) "eps_inout_fac = ",eps_inout_fac
1537 c       write (*,*) "alphapol1 = ", alphapol1
1538 c       write (*,*) "alphapol2 = ", alphapol2
1539 c       write (*,*) "fgb1 = ", fgb1
1540 c       write (*,*) "fgb2 = ", fgb2
1541 c       write (*,*) "epol = ", epol
1542 c! derivative of Epol is Gpol...
1543        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1544      &          / (fgb1 ** 5.0d0)
1545        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1546      &          / (fgb2 ** 5.0d0)
1547        dFGBdR1 = ( (R1 / MomoFac1)
1548      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
1549      &        / ( 2.0d0 * fgb1 )
1550        dFGBdR2 = ( (R2 / MomoFac2)
1551      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
1552      &        / ( 2.0d0 * fgb2 )
1553        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1554      &          * ( 2.0d0 - 0.5d0 * ee1) )
1555      &          / ( 2.0d0 * fgb1 )
1556        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1557      &          * ( 2.0d0 - 0.5d0 * ee2) )
1558      &          / ( 2.0d0 * fgb2 )
1559        dPOLdR1 = dPOLdFGB1 * dFGBdR1
1560 c!       dPOLdR1 = 0.0d0
1561        dPOLdR2 = dPOLdFGB2 * dFGBdR2
1562 c!       dPOLdR2 = 0.0d0
1563        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1564 c!       dPOLdOM1 = 0.0d0
1565        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1566 c!       dPOLdOM2 = 0.0d0
1567 c!-------------------------------------------------------------------
1568 c! Elj
1569 c! Lennard-Jones 6-12 interaction between heads
1570        pom = (pis / Rhead)**6.0d0
1571        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1572 c! derivative of Elj is Glj
1573        dGLJdR = 4.0d0 * eps_head
1574      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1575      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1576 c!-------------------------------------------------------------------
1577 c! Return the results
1578 c! These things do the dRdX derivatives, that is
1579 c! allow us to change what we see from function that changes with
1580 c! distance to function that changes with LOCATION (of the interaction
1581 c! site)
1582        DO k = 1, 3
1583         erhead(k) = Rhead_distance(k)/Rhead
1584         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1585         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1586        END DO
1587
1588        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1589        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1590        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1591        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1592        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1593        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1594        facd1 = d1 * vbld_inv(i+nres)
1595        facd2 = d2 * vbld_inv(j+nres)
1596        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1597        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1598
1599 c! Now we add appropriate partial derivatives (one in each dimension)
1600        DO k = 1, 3
1601         hawk   = (erhead_tail(k,1) +
1602      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
1603         condor = (erhead_tail(k,2) +
1604      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
1605
1606         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1607         gvdwx(k,i) = gvdwx(k,i)
1608      &             - dGCLdR * pom
1609      &             - dGGBdR * pom
1610      &             - dGCVdR * pom
1611      &             - dPOLdR1 * hawk
1612      &             - dPOLdR2 * (erhead_tail(k,2)
1613      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1614      &             - dGLJdR * pom
1615
1616         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1617         gvdwx(k,j) = gvdwx(k,j)
1618      &             + dGCLdR * pom
1619      &             + dGGBdR * pom
1620      &             + dGCVdR * pom
1621      &             + dPOLdR1 * (erhead_tail(k,1)
1622      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1623      &             + dPOLdR2 * condor
1624      &             + dGLJdR * pom
1625
1626         gvdwc(k,i) = gvdwc(k,i)
1627      &             - dGCLdR * erhead(k)
1628      &             - dGGBdR * erhead(k)
1629      &             - dGCVdR * erhead(k)
1630      &             - dPOLdR1 * erhead_tail(k,1)
1631      &             - dPOLdR2 * erhead_tail(k,2)
1632      &             - dGLJdR * erhead(k)
1633
1634         gvdwc(k,j) = gvdwc(k,j)
1635      &             + dGCLdR * erhead(k)
1636      &             + dGGBdR * erhead(k)
1637      &             + dGCVdR * erhead(k)
1638      &             + dPOLdR1 * erhead_tail(k,1)
1639      &             + dPOLdR2 * erhead_tail(k,2)
1640      &             + dGLJdR * erhead(k)
1641
1642        END DO
1643        RETURN
1644       END SUBROUTINE eqq
1645 c!-------------------------------------------------------------------
1646       SUBROUTINE energy_quad
1647      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1648        IMPLICIT NONE
1649        INCLUDE 'DIMENSIONS'
1650        INCLUDE 'DIMENSIONS.ZSCOPT'
1651        INCLUDE 'COMMON.CALC'
1652        INCLUDE 'COMMON.CHAIN'
1653        INCLUDE 'COMMON.CONTROL'
1654        INCLUDE 'COMMON.DERIV'
1655        INCLUDE 'COMMON.EMP'
1656        INCLUDE 'COMMON.GEO'
1657        INCLUDE 'COMMON.INTERACT'
1658        INCLUDE 'COMMON.IOUNITS'
1659        INCLUDE 'COMMON.LOCAL'
1660        INCLUDE 'COMMON.NAMES'
1661        INCLUDE 'COMMON.VAR'
1662        double precision scalar
1663        double precision ener(4)
1664        double precision dcosom1(3),dcosom2(3)
1665 c! used in Epol derivatives
1666        double precision facd3, facd4
1667        double precision federmaus, adler
1668 c! Epol and Gpol analytical parameters
1669        alphapol1 = alphapol(itypi,itypj)
1670        alphapol2 = alphapol(itypj,itypi)
1671 c! Fisocav and Gisocav analytical parameters
1672        al1  = alphiso(1,itypi,itypj)
1673        al2  = alphiso(2,itypi,itypj)
1674        al3  = alphiso(3,itypi,itypj)
1675        al4  = alphiso(4,itypi,itypj)
1676        csig = (1.0d0
1677      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1678      &      + sigiso2(itypi,itypj)**2.0d0))
1679 c!
1680        w1   = wqdip(1,itypi,itypj)
1681        w2   = wqdip(2,itypi,itypj)
1682        pis  = sig0head(itypi,itypj)
1683        eps_head = epshead(itypi,itypj)
1684 c! First things first:
1685 c! We need to do sc_grad's job with GB and Fcav
1686        eom1  =
1687      &         eps2der * eps2rt_om1
1688      &       - 2.0D0 * alf1 * eps3der
1689      &       + sigder * sigsq_om1
1690      &       + dCAVdOM1
1691        eom2  =
1692      &         eps2der * eps2rt_om2
1693      &       + 2.0D0 * alf2 * eps3der
1694      &       + sigder * sigsq_om2
1695      &       + dCAVdOM2
1696        eom12 =
1697      &         evdwij  * eps1_om12
1698      &       + eps2der * eps2rt_om12
1699      &       - 2.0D0 * alf12 * eps3der
1700      &       + sigder *sigsq_om12
1701      &       + dCAVdOM12
1702 c! now some magical transformations to project gradient into
1703 c! three cartesian vectors
1704        DO k = 1, 3
1705         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1706         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1707         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
1708 c! this acts on hydrophobic center of interaction
1709         gvdwx(k,i)= gvdwx(k,i) - gg(k)
1710      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1711      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1712         gvdwx(k,j)= gvdwx(k,j) + gg(k)
1713      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1714      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1715 c! this acts on Calpha
1716         gvdwc(k,i)=gvdwc(k,i)-gg(k)
1717         gvdwc(k,j)=gvdwc(k,j)+gg(k)
1718        END DO
1719 c! sc_grad is done, now we will compute
1720        eheadtail = 0.0d0
1721        eom1 = 0.0d0
1722        eom2 = 0.0d0
1723        eom12 = 0.0d0
1724
1725 c! ENERGY DEBUG
1726 c!       ii = 1
1727 c!       jj = 1
1728 c!       d1 = dhead(1, 1, itypi, itypj)
1729 c!       d2 = dhead(2, 1, itypi, itypj)
1730 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1731 c!     &        +dhead(1,ii,itypi,itypj))**2))
1732 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1733 c!     &        +dhead(2,jj,itypi,itypj))**2))
1734 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1735 c! END OF ENERGY DEBUG
1736 c*************************************************************
1737        DO istate = 1, nstate(itypi,itypj)
1738 c*************************************************************
1739         IF (istate.ne.1) THEN
1740          IF (istate.lt.3) THEN
1741           ii = 1
1742          ELSE
1743           ii = 2
1744          END IF
1745         jj = istate/ii
1746         d1 = dhead(1,ii,itypi,itypj)
1747         d2 = dhead(2,jj,itypi,itypj)
1748         DO k = 1,3
1749          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
1750          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
1751          Rhead_distance(k) = chead(k,2) - chead(k,1)
1752         END DO
1753 c! pitagoras (root of sum of squares)
1754         Rhead = dsqrt(
1755      &          (Rhead_distance(1)*Rhead_distance(1))
1756      &        + (Rhead_distance(2)*Rhead_distance(2))
1757      &        + (Rhead_distance(3)*Rhead_distance(3)))
1758         END IF
1759         Rhead_sq = Rhead * Rhead
1760
1761 c! R1 - distance between head of ith side chain and tail of jth sidechain
1762 c! R2 - distance between head of jth side chain and tail of ith sidechain
1763         R1 = 0.0d0
1764         R2 = 0.0d0
1765         DO k = 1, 3
1766 c! Calculate head-to-tail distances
1767          R1=R1+(ctail(k,2)-chead(k,1))**2
1768          R2=R2+(chead(k,2)-ctail(k,1))**2
1769         END DO
1770 c! Pitagoras
1771         R1 = dsqrt(R1)
1772         R2 = dsqrt(R2)
1773
1774 c! ENERGY DEBUG
1775 c!      write (*,*) "istate = ", istate
1776 c!      write (*,*) "ii = ", ii
1777 c!      write (*,*) "jj = ", jj
1778 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1779 c!     &        +dhead(1,ii,itypi,itypj))**2))
1780 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1781 c!     &        +dhead(2,jj,itypi,itypj))**2))
1782 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1783 c!      Rhead_sq = Rhead * Rhead
1784 c!      write (*,*) "d1 = ",d1
1785 c!      write (*,*) "d2 = ",d2
1786 c!      write (*,*) "R1 = ",R1
1787 c!      write (*,*) "R2 = ",R2
1788 c!      write (*,*) "Rhead = ",Rhead
1789 c! END OF ENERGY DEBUG
1790
1791 c!-------------------------------------------------------------------
1792 c! Coulomb electrostatic interaction
1793         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
1794 c!        Ecl = 0.0d0
1795 c!        write (*,*) "Ecl = ", Ecl
1796 c! derivative of Ecl is Gcl...
1797         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
1798 c!        dGCLdR = 0.0d0
1799         dGCLdOM1 = 0.0d0
1800         dGCLdOM2 = 0.0d0
1801         dGCLdOM12 = 0.0d0
1802 c!-------------------------------------------------------------------
1803 c! Generalised Born Solvent Polarization
1804         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1805         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1806         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1807 c!        Egb = 0.0d0
1808 c!      write (*,*) "a1*a2 = ", a12sq
1809 c!      write (*,*) "Rhead = ", Rhead
1810 c!      write (*,*) "Rhead_sq = ", Rhead_sq
1811 c!      write (*,*) "ee = ", ee
1812 c!      write (*,*) "Fgb = ", Fgb
1813 c!      write (*,*) "fac = ", eps_inout_fac
1814 c!      write (*,*) "Qij = ", Qij
1815 c!      write (*,*) "Egb = ", Egb
1816 c! Derivative of Egb is Ggb...
1817 c! dFGBdR is used by Quad's later...
1818         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1819         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1820      &         / ( 2.0d0 * Fgb )
1821         dGGBdR = dGGBdFGB * dFGBdR
1822 c!        dGGBdR = 0.0d0
1823 c!-------------------------------------------------------------------
1824 c! Fisocav - isotropic cavity creation term
1825         pom = Rhead * csig
1826         top = al1 * (dsqrt(pom) + al2 * pom - al3)
1827         bot = (1.0d0 + al4 * pom**12.0d0)
1828         botsq = bot * bot
1829         FisoCav = top / bot
1830 c!        FisoCav = 0.0d0
1831 c!      write (*,*) "pom = ",pom
1832 c!      write (*,*) "al1 = ",al1
1833 c!      write (*,*) "al2 = ",al2
1834 c!      write (*,*) "al3 = ",al3
1835 c!      write (*,*) "al4 = ",al4
1836 c!      write (*,*) "top = ",top
1837 c!      write (*,*) "bot = ",bot
1838 c!      write (*,*) "Fisocav = ", Fisocav
1839
1840 c! Derivative of Fisocav is GCV...
1841         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1842         dbot = 12.0d0 * al4 * pom ** 11.0d0
1843         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1844 c!        dGCVdR = 0.0d0
1845 c!-------------------------------------------------------------------
1846 c! Polarization energy
1847 c! Epol
1848         MomoFac1 = (1.0d0 - chi1 * sqom2)
1849         MomoFac2 = (1.0d0 - chi2 * sqom1)
1850         RR1  = ( R1 * R1 ) / MomoFac1
1851         RR2  = ( R2 * R2 ) / MomoFac2
1852         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1853         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1854         fgb1 = sqrt( RR1 + a12sq * ee1 )
1855         fgb2 = sqrt( RR2 + a12sq * ee2 )
1856         epol = 332.0d0 * eps_inout_fac * (
1857      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1858 c!        epol = 0.0d0
1859 c! derivative of Epol is Gpol...
1860         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1861      &            / (fgb1 ** 5.0d0)
1862         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1863      &            / (fgb2 ** 5.0d0)
1864         dFGBdR1 = ( (R1 / MomoFac1)
1865      &          * ( 2.0d0 - (0.5d0 * ee1) ) )
1866      &          / ( 2.0d0 * fgb1 )
1867         dFGBdR2 = ( (R2 / MomoFac2)
1868      &          * ( 2.0d0 - (0.5d0 * ee2) ) )
1869      &          / ( 2.0d0 * fgb2 )
1870         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1871      &           * ( 2.0d0 - 0.5d0 * ee1) )
1872      &           / ( 2.0d0 * fgb1 )
1873         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1874      &           * ( 2.0d0 - 0.5d0 * ee2) )
1875      &           / ( 2.0d0 * fgb2 )
1876         dPOLdR1 = dPOLdFGB1 * dFGBdR1
1877 c!        dPOLdR1 = 0.0d0
1878         dPOLdR2 = dPOLdFGB2 * dFGBdR2
1879 c!        dPOLdR2 = 0.0d0
1880         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1881 c!        dPOLdOM1 = 0.0d0
1882         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1883 c!        dPOLdOM2 = 0.0d0
1884 c!-------------------------------------------------------------------
1885 c! Elj
1886         pom = (pis / Rhead)**6.0d0
1887         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1888 c!        Elj = 0.0d0
1889 c! derivative of Elj is Glj
1890         dGLJdR = 4.0d0 * eps_head
1891      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1892      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1893 c!        dGLJdR = 0.0d0
1894 c!-------------------------------------------------------------------
1895 c! Equad
1896        IF (Wqd.ne.0.0d0) THEN
1897         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)
1898      &        - 37.5d0  * ( sqom1 + sqom2 )
1899      &        + 157.5d0 * ( sqom1 * sqom2 )
1900      &        - 45.0d0  * om1*om2*om12
1901         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
1902         Equad = fac * Beta1
1903 c!        Equad = 0.0d0
1904 c! derivative of Equad...
1905         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
1906 c!        dQUADdR = 0.0d0
1907         dQUADdOM1 = fac
1908      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
1909 c!        dQUADdOM1 = 0.0d0
1910         dQUADdOM2 = fac
1911      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
1912 c!        dQUADdOM2 = 0.0d0
1913         dQUADdOM12 = fac
1914      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )
1915 c!        dQUADdOM12 = 0.0d0
1916         ELSE
1917          Beta1 = 0.0d0
1918          Equad = 0.0d0
1919         END IF
1920 c!-------------------------------------------------------------------
1921 c! Return the results
1922 c! Angular stuff
1923         eom1 = dPOLdOM1 + dQUADdOM1
1924         eom2 = dPOLdOM2 + dQUADdOM2
1925         eom12 = dQUADdOM12
1926 c! now some magical transformations to project gradient into
1927 c! three cartesian vectors
1928         DO k = 1, 3
1929          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1930          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1931          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
1932         END DO
1933 c! Radial stuff
1934         DO k = 1, 3
1935          erhead(k) = Rhead_distance(k)/Rhead
1936          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1937          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1938         END DO
1939         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1940         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1941         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1942         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1943         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1944         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1945         facd1 = d1 * vbld_inv(i+nres)
1946         facd2 = d2 * vbld_inv(j+nres)
1947         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1948         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1949 c! Throw the results into gheadtail which holds gradients
1950 c! for each micro-state
1951         DO k = 1, 3
1952          hawk   = erhead_tail(k,1) +
1953      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
1954          condor = erhead_tail(k,2) +
1955      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
1956
1957          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1958 c! this acts on hydrophobic center of interaction
1959          gheadtail(k,1,1) = gheadtail(k,1,1)
1960      &                    - dGCLdR * pom
1961      &                    - dGGBdR * pom
1962      &                    - dGCVdR * pom
1963      &                    - dPOLdR1 * hawk
1964      &                    - dPOLdR2 * (erhead_tail(k,2)
1965      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1966      &                    - dGLJdR * pom
1967      &                    - dQUADdR * pom
1968      &                    - tuna(k)
1969      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1970      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1971
1972          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1973 c! this acts on hydrophobic center of interaction
1974          gheadtail(k,2,1) = gheadtail(k,2,1)
1975      &                    + dGCLdR * pom
1976      &                    + dGGBdR * pom
1977      &                    + dGCVdR * pom
1978      &                    + dPOLdR1 * (erhead_tail(k,1)
1979      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1980      &                    + dPOLdR2 * condor
1981      &                    + dGLJdR * pom
1982      &                    + dQUADdR * pom
1983      &                    + tuna(k)
1984      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1985      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1986
1987 c! this acts on Calpha
1988          gheadtail(k,3,1) = gheadtail(k,3,1)
1989      &                    - dGCLdR * erhead(k)
1990      &                    - dGGBdR * erhead(k)
1991      &                    - dGCVdR * erhead(k)
1992      &                    - dPOLdR1 * erhead_tail(k,1)
1993      &                    - dPOLdR2 * erhead_tail(k,2)
1994      &                    - dGLJdR * erhead(k)
1995      &                    - dQUADdR * erhead(k)
1996      &                    - tuna(k)
1997
1998 c! this acts on Calpha
1999          gheadtail(k,4,1) = gheadtail(k,4,1)
2000      &                    + dGCLdR * erhead(k)
2001      &                    + dGGBdR * erhead(k)
2002      &                    + dGCVdR * erhead(k)
2003      &                    + dPOLdR1 * erhead_tail(k,1)
2004      &                    + dPOLdR2 * erhead_tail(k,2)
2005      &                    + dGLJdR * erhead(k)
2006      &                    + dQUADdR * erhead(k)
2007      &                    + tuna(k)
2008         END DO
2009 c!      write(*,*) "ECL = ", Ecl
2010 c!      write(*,*) "Egb = ", Egb
2011 c!      write(*,*) "Epol = ", Epol
2012 c!      write(*,*) "Fisocav = ", Fisocav
2013 c!      write(*,*) "Elj = ", Elj
2014 c!      write(*,*) "Equad = ", Equad
2015 c!      write(*,*) "wstate = ", wstate(istate,itypi,itypj)
2016 c!      write(*,*) "eheadtail = ", eheadtail
2017 c!      write(*,*) "TROLL = ", dexp(-betaT * ener(istate))
2018 c!      write(*,*) "dGCLdR = ", dGCLdR
2019 c!      write(*,*) "dGGBdR = ", dGGBdR
2020 c!      write(*,*) "dGCVdR = ", dGCVdR
2021 c!      write(*,*) "dPOLdR1 = ", dPOLdR1
2022 c!      write(*,*) "dPOLdR2 = ", dPOLdR2
2023 c!      write(*,*) "dGLJdR = ", dGLJdR
2024 c!      write(*,*) "dQUADdR = ", dQUADdR
2025 c!      write(*,*) "tuna(",k,") = ", tuna(k)
2026         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
2027         eheadtail = eheadtail
2028      &            + wstate(istate, itypi, itypj)
2029      &            * dexp(-betaT * ener(istate))
2030 c! foreach cartesian dimension
2031         DO k = 1, 3
2032 c! foreach of two gvdwx and gvdwc
2033          DO l = 1, 4
2034           gheadtail(k,l,2) = gheadtail(k,l,2)
2035      &                     + wstate( istate, itypi, itypj )
2036      &                     * dexp(-betaT * ener(istate))
2037      &                     * gheadtail(k,l,1)
2038           gheadtail(k,l,1) = 0.0d0
2039          END DO
2040         END DO
2041        END DO
2042 c! Here ended the gigantic DO istate = 1, 4, which starts
2043 c! at the beggining of the subroutine
2044
2045        DO k = 1, 3
2046         DO l = 1, 4
2047          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
2048         END DO
2049         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
2050         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
2051         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
2052         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
2053         DO l = 1, 4
2054          gheadtail(k,l,1) = 0.0d0
2055          gheadtail(k,l,2) = 0.0d0
2056         END DO
2057        END DO
2058        eheadtail = (-dlog(eheadtail)) / betaT
2059        dPOLdOM1 = 0.0d0
2060        dPOLdOM2 = 0.0d0
2061        dQUADdOM1 = 0.0d0
2062        dQUADdOM2 = 0.0d0
2063        dQUADdOM12 = 0.0d0
2064        RETURN
2065       END SUBROUTINE energy_quad
2066
2067
2068 c!-------------------------------------------------------------------
2069
2070
2071       SUBROUTINE eqn(Epol)
2072       IMPLICIT NONE
2073       INCLUDE 'DIMENSIONS'
2074       INCLUDE 'DIMENSIONS.ZSCOPT'
2075       INCLUDE 'COMMON.CALC'
2076       INCLUDE 'COMMON.CHAIN'
2077       INCLUDE 'COMMON.CONTROL'
2078       INCLUDE 'COMMON.DERIV'
2079       INCLUDE 'COMMON.EMP'
2080       INCLUDE 'COMMON.GEO'
2081       INCLUDE 'COMMON.INTERACT'
2082       INCLUDE 'COMMON.IOUNITS'
2083       INCLUDE 'COMMON.LOCAL'
2084       INCLUDE 'COMMON.NAMES'
2085       INCLUDE 'COMMON.VAR'
2086       double precision scalar, facd4, federmaus
2087       alphapol1 = alphapol(itypi,itypj)
2088 c! R1 - distance between head of ith side chain and tail of jth sidechain
2089        R1 = 0.0d0
2090        DO k = 1, 3
2091 c! Calculate head-to-tail distances
2092         R1=R1+(ctail(k,2)-chead(k,1))**2
2093        END DO
2094 c! Pitagoras
2095        R1 = dsqrt(R1)
2096
2097 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2098 c!     &        +dhead(1,1,itypi,itypj))**2))
2099 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2100 c!     &        +dhead(2,1,itypi,itypj))**2))
2101 c--------------------------------------------------------------------
2102 c Polarization energy
2103 c Epol
2104        MomoFac1 = (1.0d0 - chi1 * sqom2)
2105        RR1  = R1 * R1 / MomoFac1
2106        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2107        fgb1 = sqrt( RR1 + a12sq * ee1)
2108        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2109 c!       epol = 0.0d0
2110 c!------------------------------------------------------------------
2111 c! derivative of Epol is Gpol...
2112        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2113      &          / (fgb1 ** 5.0d0)
2114        dFGBdR1 = ( (R1 / MomoFac1)
2115      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2116      &        / ( 2.0d0 * fgb1 )
2117        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2118      &          * (2.0d0 - 0.5d0 * ee1) )
2119      &          / (2.0d0 * fgb1)
2120        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2121 c!       dPOLdR1 = 0.0d0
2122        dPOLdOM1 = 0.0d0
2123        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2124 c!       dPOLdOM2 = 0.0d0
2125 c!-------------------------------------------------------------------
2126 c! Return the results
2127 c! (see comments in Eqq)
2128        DO k = 1, 3
2129         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2130        END DO
2131        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2132        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2133        facd1 = d1 * vbld_inv(i+nres)
2134        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2135
2136        DO k = 1, 3
2137         hawk = (erhead_tail(k,1) +
2138      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2139
2140         gvdwx(k,i) = gvdwx(k,i)
2141      &             - dPOLdR1 * hawk
2142         gvdwx(k,j) = gvdwx(k,j)
2143      &             + dPOLdR1 * (erhead_tail(k,1)
2144      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2145
2146         gvdwc(k,i) = gvdwc(k,i)
2147      &             - dPOLdR1 * erhead_tail(k,1)
2148         gvdwc(k,j) = gvdwc(k,j)
2149      &             + dPOLdR1 * erhead_tail(k,1)
2150
2151        END DO
2152        RETURN
2153       END SUBROUTINE eqn
2154
2155
2156 c!-------------------------------------------------------------------
2157
2158
2159
2160       SUBROUTINE enq(Epol)
2161        IMPLICIT NONE
2162        INCLUDE 'DIMENSIONS'
2163        INCLUDE 'DIMENSIONS.ZSCOPT'
2164        INCLUDE 'COMMON.CALC'
2165        INCLUDE 'COMMON.CHAIN'
2166        INCLUDE 'COMMON.CONTROL'
2167        INCLUDE 'COMMON.DERIV'
2168        INCLUDE 'COMMON.EMP'
2169        INCLUDE 'COMMON.GEO'
2170        INCLUDE 'COMMON.INTERACT'
2171        INCLUDE 'COMMON.IOUNITS'
2172        INCLUDE 'COMMON.LOCAL'
2173        INCLUDE 'COMMON.NAMES'
2174        INCLUDE 'COMMON.VAR'
2175        double precision scalar, facd3, adler
2176        alphapol2 = alphapol(itypj,itypi)
2177 c! R2 - distance between head of jth side chain and tail of ith sidechain
2178        R2 = 0.0d0
2179        DO k = 1, 3
2180 c! Calculate head-to-tail distances
2181         R2=R2+(chead(k,2)-ctail(k,1))**2
2182        END DO
2183 c! Pitagoras
2184        R2 = dsqrt(R2)
2185
2186 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2187 c!     &        +dhead(1,1,itypi,itypj))**2))
2188 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2189 c!     &        +dhead(2,1,itypi,itypj))**2))
2190 c------------------------------------------------------------------------
2191 c Polarization energy
2192        MomoFac2 = (1.0d0 - chi2 * sqom1)
2193        RR2  = R2 * R2 / MomoFac2
2194        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2195        fgb2 = sqrt(RR2  + a12sq * ee2)
2196        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2197 c!       epol = 0.0d0
2198 c!-------------------------------------------------------------------
2199 c! derivative of Epol is Gpol...
2200        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2201      &          / (fgb2 ** 5.0d0)
2202        dFGBdR2 = ( (R2 / MomoFac2)
2203      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2204      &        / (2.0d0 * fgb2)
2205        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2206      &          * (2.0d0 - 0.5d0 * ee2) )
2207      &          / (2.0d0 * fgb2)
2208        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2209 c!       dPOLdR2 = 0.0d0
2210        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2211 c!       dPOLdOM1 = 0.0d0
2212        dPOLdOM2 = 0.0d0
2213 c!-------------------------------------------------------------------
2214 c! Return the results
2215 c! (See comments in Eqq)
2216        DO k = 1, 3
2217         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2218        END DO
2219        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2220        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2221        facd2 = d2 * vbld_inv(j+nres)
2222        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2223        DO k = 1, 3
2224         condor = (erhead_tail(k,2)
2225      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2226
2227         gvdwx(k,i) = gvdwx(k,i)
2228      &             - dPOLdR2 * (erhead_tail(k,2)
2229      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2230         gvdwx(k,j) = gvdwx(k,j)
2231      &             + dPOLdR2 * condor
2232
2233         gvdwc(k,i) = gvdwc(k,i)
2234      &             - dPOLdR2 * erhead_tail(k,2)
2235         gvdwc(k,j) = gvdwc(k,j)
2236      &             + dPOLdR2 * erhead_tail(k,2)
2237
2238        END DO
2239       RETURN
2240       END SUBROUTINE enq
2241
2242
2243 c!-------------------------------------------------------------------
2244
2245
2246       SUBROUTINE eqd(Ecl,Elj,Epol)
2247        IMPLICIT NONE
2248        INCLUDE 'DIMENSIONS'
2249        INCLUDE 'DIMENSIONS.ZSCOPT'
2250        INCLUDE 'COMMON.CALC'
2251        INCLUDE 'COMMON.CHAIN'
2252        INCLUDE 'COMMON.CONTROL'
2253        INCLUDE 'COMMON.DERIV'
2254        INCLUDE 'COMMON.EMP'
2255        INCLUDE 'COMMON.GEO'
2256        INCLUDE 'COMMON.INTERACT'
2257        INCLUDE 'COMMON.IOUNITS'
2258        INCLUDE 'COMMON.LOCAL'
2259        INCLUDE 'COMMON.NAMES'
2260        INCLUDE 'COMMON.VAR'
2261        double precision scalar, facd4, federmaus
2262        alphapol1 = alphapol(itypi,itypj)
2263        w1        = wqdip(1,itypi,itypj)
2264        w2        = wqdip(2,itypi,itypj)
2265        pis       = sig0head(itypi,itypj)
2266        eps_head   = epshead(itypi,itypj)
2267 c!-------------------------------------------------------------------
2268 c! R1 - distance between head of ith side chain and tail of jth sidechain
2269        R1 = 0.0d0
2270        DO k = 1, 3
2271 c! Calculate head-to-tail distances
2272         R1=R1+(ctail(k,2)-chead(k,1))**2
2273        END DO
2274 c! Pitagoras
2275        R1 = dsqrt(R1)
2276
2277 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2278 c!     &        +dhead(1,1,itypi,itypj))**2))
2279 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2280 c!     &        +dhead(2,1,itypi,itypj))**2))
2281
2282 c!-------------------------------------------------------------------
2283 c! ecl
2284        sparrow  = w1 * Qi * om1
2285        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2286        Ecl = sparrow / Rhead**2.0d0
2287      &     - hawk    / Rhead**4.0d0
2288 c!-------------------------------------------------------------------
2289 c! derivative of ecl is Gcl
2290 c! dF/dr part
2291        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2292      &           + 4.0d0 * hawk    / Rhead**5.0d0
2293 c! dF/dom1
2294        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2295 c! dF/dom2
2296        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2297 c--------------------------------------------------------------------
2298 c Polarization energy
2299 c Epol
2300        MomoFac1 = (1.0d0 - chi1 * sqom2)
2301        RR1  = R1 * R1 / MomoFac1
2302        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2303        fgb1 = sqrt( RR1 + a12sq * ee1)
2304        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2305 c!       epol = 0.0d0
2306 c!------------------------------------------------------------------
2307 c! derivative of Epol is Gpol...
2308        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2309      &          / (fgb1 ** 5.0d0)
2310        dFGBdR1 = ( (R1 / MomoFac1)
2311      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2312      &        / ( 2.0d0 * fgb1 )
2313        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2314      &          * (2.0d0 - 0.5d0 * ee1) )
2315      &          / (2.0d0 * fgb1)
2316        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2317 c!       dPOLdR1 = 0.0d0
2318        dPOLdOM1 = 0.0d0
2319        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2320 c!       dPOLdOM2 = 0.0d0
2321 c!-------------------------------------------------------------------
2322 c! Elj
2323        pom = (pis / Rhead)**6.0d0
2324        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2325 c! derivative of Elj is Glj
2326        dGLJdR = 4.0d0 * eps_head
2327      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2328      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2329 c!-------------------------------------------------------------------
2330 c! Return the results
2331        DO k = 1, 3
2332         erhead(k) = Rhead_distance(k)/Rhead
2333         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2334        END DO
2335
2336        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2337        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2338        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2339        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2340        facd1 = d1 * vbld_inv(i+nres)
2341        facd2 = d2 * vbld_inv(j+nres)
2342        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2343
2344        DO k = 1, 3
2345         hawk = (erhead_tail(k,1) +
2346      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2347
2348         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2349         gvdwx(k,i) = gvdwx(k,i)
2350      &             - dGCLdR * pom
2351      &             - dPOLdR1 * hawk
2352      &             - dGLJdR * pom
2353
2354         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2355         gvdwx(k,j) = gvdwx(k,j)
2356      &             + dGCLdR * pom
2357      &             + dPOLdR1 * (erhead_tail(k,1)
2358      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2359      &             + dGLJdR * pom
2360
2361
2362         gvdwc(k,i) = gvdwc(k,i)
2363      &             - dGCLdR * erhead(k)
2364      &             - dPOLdR1 * erhead_tail(k,1)
2365      &             - dGLJdR * erhead(k)
2366
2367         gvdwc(k,j) = gvdwc(k,j)
2368      &             + dGCLdR * erhead(k)
2369      &             + dPOLdR1 * erhead_tail(k,1)
2370      &             + dGLJdR * erhead(k)
2371
2372        END DO
2373        RETURN
2374       END SUBROUTINE eqd
2375
2376
2377 c!-------------------------------------------------------------------
2378
2379
2380       SUBROUTINE edq(Ecl,Elj,Epol)
2381        IMPLICIT NONE
2382        INCLUDE 'DIMENSIONS'
2383        INCLUDE 'DIMENSIONS.ZSCOPT'
2384        INCLUDE 'COMMON.CALC'
2385        INCLUDE 'COMMON.CHAIN'
2386        INCLUDE 'COMMON.CONTROL'
2387        INCLUDE 'COMMON.DERIV'
2388        INCLUDE 'COMMON.EMP'
2389        INCLUDE 'COMMON.GEO'
2390        INCLUDE 'COMMON.INTERACT'
2391        INCLUDE 'COMMON.IOUNITS'
2392        INCLUDE 'COMMON.LOCAL'
2393        INCLUDE 'COMMON.NAMES'
2394        INCLUDE 'COMMON.VAR'
2395        double precision scalar, facd3, adler
2396        alphapol2 = alphapol(itypj,itypi)
2397        w1        = wqdip(1,itypi,itypj)
2398        w2        = wqdip(2,itypi,itypj)
2399        pis       = sig0head(itypi,itypj)
2400        eps_head  = epshead(itypi,itypj)
2401 c!-------------------------------------------------------------------
2402 c! R2 - distance between head of jth side chain and tail of ith sidechain
2403        R2 = 0.0d0
2404        DO k = 1, 3
2405 c! Calculate head-to-tail distances
2406         R2=R2+(chead(k,2)-ctail(k,1))**2
2407        END DO
2408 c! Pitagoras
2409        R2 = dsqrt(R2)
2410
2411 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2412 c!     &        +dhead(1,1,itypi,itypj))**2))
2413 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2414 c!     &        +dhead(2,1,itypi,itypj))**2))
2415
2416
2417 c!-------------------------------------------------------------------
2418 c! ecl
2419        sparrow  = w1 * Qi * om1
2420        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2421        ECL = sparrow / Rhead**2.0d0
2422      &     - hawk    / Rhead**4.0d0
2423 c!-------------------------------------------------------------------
2424 c! derivative of ecl is Gcl
2425 c! dF/dr part
2426        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2427      &           + 4.0d0 * hawk    / Rhead**5.0d0
2428 c! dF/dom1
2429        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2430 c! dF/dom2
2431        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2432 c--------------------------------------------------------------------
2433 c Polarization energy
2434 c Epol
2435        MomoFac2 = (1.0d0 - chi2 * sqom1)
2436        RR2  = R2 * R2 / MomoFac2
2437        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2438        fgb2 = sqrt(RR2  + a12sq * ee2)
2439        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2440 c!       epol = 0.0d0
2441 c! derivative of Epol is Gpol...
2442        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2443      &          / (fgb2 ** 5.0d0)
2444        dFGBdR2 = ( (R2 / MomoFac2)
2445      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2446      &        / (2.0d0 * fgb2)
2447        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2448      &          * (2.0d0 - 0.5d0 * ee2) )
2449      &          / (2.0d0 * fgb2)
2450        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2451 c!       dPOLdR2 = 0.0d0
2452        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2453 c!       dPOLdOM1 = 0.0d0
2454        dPOLdOM2 = 0.0d0
2455 c!-------------------------------------------------------------------
2456 c! Elj
2457        pom = (pis / Rhead)**6.0d0
2458        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2459 c! derivative of Elj is Glj
2460        dGLJdR = 4.0d0 * eps_head
2461      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2462      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2463 c!-------------------------------------------------------------------
2464 c! Return the results
2465 c! (see comments in Eqq)
2466        DO k = 1, 3
2467         erhead(k) = Rhead_distance(k)/Rhead
2468         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2469        END DO
2470        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2471        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2472        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2473        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2474        facd1 = d1 * vbld_inv(i+nres)
2475        facd2 = d2 * vbld_inv(j+nres)
2476        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2477
2478        DO k = 1, 3
2479         condor = (erhead_tail(k,2)
2480      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2481
2482         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2483         gvdwx(k,i) = gvdwx(k,i)
2484      &             - dGCLdR * pom
2485      &             - dPOLdR2 * (erhead_tail(k,2)
2486      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2487      &             - dGLJdR * pom
2488
2489         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2490         gvdwx(k,j) = gvdwx(k,j)
2491      &             + dGCLdR * pom
2492      &             + dPOLdR2 * condor
2493      &             + dGLJdR * pom
2494
2495
2496         gvdwc(k,i) = gvdwc(k,i)
2497      &             - dGCLdR * erhead(k)
2498      &             - dPOLdR2 * erhead_tail(k,2)
2499      &             - dGLJdR * erhead(k)
2500
2501         gvdwc(k,j) = gvdwc(k,j)
2502      &             + dGCLdR * erhead(k)
2503      &             + dPOLdR2 * erhead_tail(k,2)
2504      &             + dGLJdR * erhead(k)
2505
2506        END DO
2507        RETURN
2508       END SUBROUTINE edq
2509
2510
2511 C--------------------------------------------------------------------
2512
2513
2514       SUBROUTINE edd(ECL)
2515        IMPLICIT NONE
2516        INCLUDE 'DIMENSIONS'
2517        INCLUDE 'DIMENSIONS.ZSCOPT'
2518        INCLUDE 'COMMON.CALC'
2519        INCLUDE 'COMMON.CHAIN'
2520        INCLUDE 'COMMON.CONTROL'
2521        INCLUDE 'COMMON.DERIV'
2522        INCLUDE 'COMMON.EMP'
2523        INCLUDE 'COMMON.GEO'
2524        INCLUDE 'COMMON.INTERACT'
2525        INCLUDE 'COMMON.IOUNITS'
2526        INCLUDE 'COMMON.LOCAL'
2527        INCLUDE 'COMMON.NAMES'
2528        INCLUDE 'COMMON.VAR'
2529        double precision scalar
2530 c!       csig = sigiso(itypi,itypj)
2531        w1 = wqdip(1,itypi,itypj)
2532        w2 = wqdip(2,itypi,itypj)
2533 c!-------------------------------------------------------------------
2534 c! ECL
2535        fac = (om12 - 3.0d0 * om1 * om2)
2536        c1 = (w1 / (Rhead**3.0d0)) * fac
2537        c2 = (w2 / Rhead ** 6.0d0)
2538      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2539        ECL = c1 - c2
2540 c!       write (*,*) "w1 = ", w1
2541 c!       write (*,*) "w2 = ", w2
2542 c!       write (*,*) "om1 = ", om1
2543 c!       write (*,*) "om2 = ", om2
2544 c!       write (*,*) "om12 = ", om12
2545 c!       write (*,*) "fac = ", fac
2546 c!       write (*,*) "c1 = ", c1
2547 c!       write (*,*) "c2 = ", c2
2548 c!       write (*,*) "Ecl = ", Ecl
2549 c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
2550 c!       write (*,*) "c2_2 = ",
2551 c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2552 c!-------------------------------------------------------------------
2553 c! dervative of ECL is GCL...
2554 c! dECL/dr
2555        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
2556        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)
2557      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
2558        dGCLdR = c1 - c2
2559 c! dECL/dom1
2560        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
2561        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2562      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
2563        dGCLdOM1 = c1 - c2
2564 c! dECL/dom2
2565        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
2566        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2567      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
2568        dGCLdOM2 = c1 - c2
2569 c! dECL/dom12
2570        c1 = w1 / (Rhead ** 3.0d0)
2571        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
2572        dGCLdOM12 = c1 - c2
2573 c!-------------------------------------------------------------------
2574 c! Return the results
2575 c! (see comments in Eqq)
2576        DO k= 1, 3
2577         erhead(k) = Rhead_distance(k)/Rhead
2578        END DO
2579        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2580        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2581        facd1 = d1 * vbld_inv(i+nres)
2582        facd2 = d2 * vbld_inv(j+nres)
2583        DO k = 1, 3
2584
2585         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2586         gvdwx(k,i) = gvdwx(k,i)
2587      &             - dGCLdR * pom
2588         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2589         gvdwx(k,j) = gvdwx(k,j)
2590      &             + dGCLdR * pom
2591
2592         gvdwc(k,i) = gvdwc(k,i)
2593      &             - dGCLdR * erhead(k)
2594         gvdwc(k,j) = gvdwc(k,j)
2595      &             + dGCLdR * erhead(k)
2596        END DO
2597        RETURN
2598       END SUBROUTINE edd
2599
2600
2601 c!-------------------------------------------------------------------
2602
2603
2604       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
2605        IMPLICIT NONE
2606 c! maxres
2607        INCLUDE 'DIMENSIONS'
2608 c! itypi, itypj, i, j, k, l, chead,
2609        INCLUDE 'COMMON.CALC'
2610 c! c, nres, dc_norm
2611        INCLUDE 'COMMON.CHAIN'
2612 c! gradc, gradx
2613        INCLUDE 'COMMON.DERIV'
2614 c! electrostatic gradients-specific variables
2615        INCLUDE 'COMMON.EMP'
2616 c! wquad, dhead, alphiso, alphasur, rborn, epsintab
2617        INCLUDE 'COMMON.INTERACT'
2618 c! io for debug, disable it in final builds
2619        INCLUDE 'COMMON.IOUNITS'
2620 c!-------------------------------------------------------------------
2621 c! Variable Init
2622
2623 c! what amino acid is the aminoacid j'th?
2624        itypj = itype(j)
2625 c! 1/(Gas Constant * Thermostate temperature) = BetaT
2626 c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
2627        BetaT = 1.0d0 / (298 * 1.987d-3)
2628 c! Gay-berne var's
2629        sig0ij = sigma( itypi,itypj )
2630        chi1   = chi( itypi, itypj )
2631        chi2   = chi( itypj, itypi )
2632        chi12  = chi1 * chi2
2633        chip1  = chipp( itypi, itypj )
2634        chip2  = chipp( itypj, itypi )
2635        chip12 = chip1 * chip2
2636 c!       write (2,*) "elgrad types",itypi,itypj,
2637 c!     & " chi1",chi1," chi2",chi2," chi12",chi12,
2638 c!     &  " chip1",chip1," chip2",chip2," chip12",chip12
2639 c! not used by momo potential, but needed by sc_angular which is shared
2640 c! by all energy_potential subroutines
2641        alf1   = 0.0d0
2642        alf2   = 0.0d0
2643        alf12  = 0.0d0
2644 c! location, location, location
2645        xj  = c( 1, nres+j ) - xi
2646        yj  = c( 2, nres+j ) - yi
2647        zj  = c( 3, nres+j ) - zi
2648        dxj = dc_norm( 1, nres+j )
2649        dyj = dc_norm( 2, nres+j )
2650        dzj = dc_norm( 3, nres+j )
2651 c! distance from center of chain(?) to polar/charged head
2652 c!       write (*,*) "istate = ", 1
2653 c!       write (*,*) "ii = ", 1
2654 c!       write (*,*) "jj = ", 1
2655        d1 = dhead(1, 1, itypi, itypj)
2656        d2 = dhead(2, 1, itypi, itypj)
2657 c! ai*aj from Fgb
2658        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
2659 c!       a12sq = a12sq * a12sq
2660 c! charge of amino acid itypi is...
2661        Qi  = icharge(itypi)
2662        Qj  = icharge(itypj)
2663        Qij = Qi * Qj
2664 c! chis1,2,12
2665        chis1 = chis(itypi,itypj)
2666        chis2 = chis(itypj,itypi)
2667        chis12 = chis1 * chis2
2668        sig1 = sigmap1(itypi,itypj)
2669        sig2 = sigmap2(itypi,itypj)
2670 c!       write (*,*) "sig1 = ", sig1
2671 c!       write (*,*) "sig2 = ", sig2
2672 c! alpha factors from Fcav/Gcav
2673        b1 = alphasur(1,itypi,itypj)
2674        b2 = alphasur(2,itypi,itypj)
2675        b3 = alphasur(3,itypi,itypj)
2676        b4 = alphasur(4,itypi,itypj)
2677 c! used to determine whether we want to do quadrupole calculations
2678        wqd = wquad(itypi, itypj)
2679 c! used by Fgb
2680        eps_in = epsintab(itypi,itypj)
2681        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
2682 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
2683 c!-------------------------------------------------------------------
2684 c! tail location and distance calculations
2685        Rtail = 0.0d0
2686        DO k = 1, 3
2687         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
2688         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
2689        END DO
2690 c! tail distances will be themselves usefull elswhere
2691 c1 (in Gcav, for example)
2692        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
2693        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
2694        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
2695        Rtail = dsqrt(
2696      &     (Rtail_distance(1)*Rtail_distance(1))
2697      &   + (Rtail_distance(2)*Rtail_distance(2))
2698      &   + (Rtail_distance(3)*Rtail_distance(3)))
2699 c!-------------------------------------------------------------------
2700 c! Calculate location and distance between polar heads
2701 c! distance between heads
2702 c! for each one of our three dimensional space...
2703        DO k = 1,3
2704 c! location of polar head is computed by taking hydrophobic centre
2705 c! and moving by a d1 * dc_norm vector
2706 c! see unres publications for very informative images
2707         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
2708         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
2709 c! distance
2710 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
2711 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
2712         Rhead_distance(k) = chead(k,2) - chead(k,1)
2713        END DO
2714 c! pitagoras (root of sum of squares)
2715        Rhead = dsqrt(
2716      &     (Rhead_distance(1)*Rhead_distance(1))
2717      &   + (Rhead_distance(2)*Rhead_distance(2))
2718      &   + (Rhead_distance(3)*Rhead_distance(3)))
2719 c!-------------------------------------------------------------------
2720 c! zero everything that should be zero'ed
2721        Egb = 0.0d0
2722        ECL = 0.0d0
2723        Elj = 0.0d0
2724        Equad = 0.0d0
2725        Epol = 0.0d0
2726        eheadtail = 0.0d0
2727        dGCLdOM1 = 0.0d0
2728        dGCLdOM2 = 0.0d0
2729        dGCLdOM12 = 0.0d0
2730        dPOLdOM1 = 0.0d0
2731        dPOLdOM2 = 0.0d0
2732        RETURN
2733       END SUBROUTINE elgrad_init
2734 c!-------------------------------------------------------------------
2735       subroutine sc_angular
2736 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2737 C om12. Called by ebp, egb, and egbv.
2738       implicit none
2739       include 'COMMON.CALC'
2740       include 'COMMON.IOUNITS'
2741       erij(1)=xj*rij
2742       erij(2)=yj*rij
2743       erij(3)=zj*rij
2744       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2745       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2746       om12=dxi*dxj+dyi*dyj+dzi*dzj
2747 c!      om1    = 0.0d0
2748 c!      om2    = 0.0d0
2749 c!      om12   = 0.0d0
2750       chiom12=chi12*om12
2751 C Calculate eps1(om12) and its derivative in om12
2752       faceps1=1.0D0-om12*chiom12
2753       faceps1_inv=1.0D0/faceps1
2754       eps1=dsqrt(faceps1_inv)
2755 c      write (2,*) "chi1",chi1," chi2",chi2," chi12",chi12
2756 c      write (2,*) "fsceps1",faceps1," faceps1_inv",faceps1_inv,
2757 c     & " eps1",eps1
2758 C Following variable is eps1*deps1/dom12
2759       eps1_om12=faceps1_inv*chiom12
2760 c diagnostics only
2761 c      faceps1_inv=om12
2762 c      eps1=om12
2763 c      eps1_om12=1.0d0
2764 c      write (iout,*) "om12",om12," eps1",eps1
2765 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2766 C and om12.
2767       om1om2=om1*om2
2768       chiom1=chi1*om1
2769       chiom2=chi2*om2
2770       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2771       sigsq=1.0D0-facsig*faceps1_inv
2772 c      write (2,*) "om1",om1," om2",om2," om1om2",om1om2,
2773 c     & " chiom1",chiom1,
2774 c     &  " chiom2",chiom2," facsig",facsig," sigsq",sigsq
2775       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2776       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2777       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2778 c diagnostics only
2779 c      sigsq=1.0d0
2780 c      sigsq_om1=0.0d0
2781 c      sigsq_om2=0.0d0
2782 c      sigsq_om12=0.0d0
2783 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2784 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2785 c     &    " eps1",eps1
2786 C Calculate eps2 and its derivatives in om1, om2, and om12.
2787       chipom1=chip1*om1
2788       chipom2=chip2*om2
2789       chipom12=chip12*om12
2790       facp=1.0D0-om12*chipom12
2791       facp_inv=1.0D0/facp
2792       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2793 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2794 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2795 C Following variable is the square root of eps2
2796       eps2rt=1.0D0-facp1*facp_inv
2797 C Following three variables are the derivatives of the square root of eps
2798 C in om1, om2, and om12.
2799       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2800       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2801       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2802 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2803 c! Note that THIS is 0 in emomo, so we should probably move it out of sc_angular
2804 c! Or frankly, we should restructurize the whole energy section
2805       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2806 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2807 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2808 c     &  " eps2rt_om12",eps2rt_om12
2809 C Calculate whole angle-dependent part of epsilon and contributions
2810 C to its derivatives
2811       return
2812       end
2813 C----------------------------------------------------------------------------
2814       subroutine sc_grad
2815       implicit real*8 (a-h,o-z)
2816       include 'DIMENSIONS'
2817       include 'DIMENSIONS.ZSCOPT'
2818       include 'COMMON.CHAIN'
2819       include 'COMMON.DERIV'
2820       include 'COMMON.CALC'
2821       double precision dcosom1(3),dcosom2(3)
2822       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2823       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2824       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2825      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2826       do k=1,3
2827         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2828         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2829       enddo
2830       do k=1,3
2831         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2832       enddo
2833       do k=1,3
2834         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2835      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2836      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2837         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2838      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2839      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2840       enddo
2841 C
2842 C Calculate the components of the gradient in DC and X
2843 C
2844       do k=i,j-1
2845         do l=1,3
2846           gvdwc(l,k)=gvdwc(l,k)+gg(l)
2847         enddo
2848       enddo
2849       return
2850       end
2851 c------------------------------------------------------------------------------
2852       subroutine vec_and_deriv
2853       implicit real*8 (a-h,o-z)
2854       include 'DIMENSIONS'
2855       include 'DIMENSIONS.ZSCOPT'
2856       include 'COMMON.IOUNITS'
2857       include 'COMMON.GEO'
2858       include 'COMMON.VAR'
2859       include 'COMMON.LOCAL'
2860       include 'COMMON.CHAIN'
2861       include 'COMMON.VECTORS'
2862       include 'COMMON.DERIV'
2863       include 'COMMON.INTERACT'
2864       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2865 C Compute the local reference systems. For reference system (i), the
2866 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2867 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2868       do i=1,nres-1
2869 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
2870           if (i.eq.nres-1) then
2871 C Case of the last full residue
2872 C Compute the Z-axis
2873             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2874             costh=dcos(pi-theta(nres))
2875             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2876             do k=1,3
2877               uz(k,i)=fac*uz(k,i)
2878             enddo
2879             if (calc_grad) then
2880 C Compute the derivatives of uz
2881             uzder(1,1,1)= 0.0d0
2882             uzder(2,1,1)=-dc_norm(3,i-1)
2883             uzder(3,1,1)= dc_norm(2,i-1)
2884             uzder(1,2,1)= dc_norm(3,i-1)
2885             uzder(2,2,1)= 0.0d0
2886             uzder(3,2,1)=-dc_norm(1,i-1)
2887             uzder(1,3,1)=-dc_norm(2,i-1)
2888             uzder(2,3,1)= dc_norm(1,i-1)
2889             uzder(3,3,1)= 0.0d0
2890             uzder(1,1,2)= 0.0d0
2891             uzder(2,1,2)= dc_norm(3,i)
2892             uzder(3,1,2)=-dc_norm(2,i)
2893             uzder(1,2,2)=-dc_norm(3,i)
2894             uzder(2,2,2)= 0.0d0
2895             uzder(3,2,2)= dc_norm(1,i)
2896             uzder(1,3,2)= dc_norm(2,i)
2897             uzder(2,3,2)=-dc_norm(1,i)
2898             uzder(3,3,2)= 0.0d0
2899             endif
2900 C Compute the Y-axis
2901             facy=fac
2902             do k=1,3
2903               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2904             enddo
2905             if (calc_grad) then
2906 C Compute the derivatives of uy
2907             do j=1,3
2908               do k=1,3
2909                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2910      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2911                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2912               enddo
2913               uyder(j,j,1)=uyder(j,j,1)-costh
2914               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2915             enddo
2916             do j=1,2
2917               do k=1,3
2918                 do l=1,3
2919                   uygrad(l,k,j,i)=uyder(l,k,j)
2920                   uzgrad(l,k,j,i)=uzder(l,k,j)
2921                 enddo
2922               enddo
2923             enddo
2924             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2925             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2926             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2927             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2928             endif
2929           else
2930 C Other residues
2931 C Compute the Z-axis
2932             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2933             costh=dcos(pi-theta(i+2))
2934             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2935             do k=1,3
2936               uz(k,i)=fac*uz(k,i)
2937             enddo
2938             if (calc_grad) then
2939 C Compute the derivatives of uz
2940             uzder(1,1,1)= 0.0d0
2941             uzder(2,1,1)=-dc_norm(3,i+1)
2942             uzder(3,1,1)= dc_norm(2,i+1)
2943             uzder(1,2,1)= dc_norm(3,i+1)
2944             uzder(2,2,1)= 0.0d0
2945             uzder(3,2,1)=-dc_norm(1,i+1)
2946             uzder(1,3,1)=-dc_norm(2,i+1)
2947             uzder(2,3,1)= dc_norm(1,i+1)
2948             uzder(3,3,1)= 0.0d0
2949             uzder(1,1,2)= 0.0d0
2950             uzder(2,1,2)= dc_norm(3,i)
2951             uzder(3,1,2)=-dc_norm(2,i)
2952             uzder(1,2,2)=-dc_norm(3,i)
2953             uzder(2,2,2)= 0.0d0
2954             uzder(3,2,2)= dc_norm(1,i)
2955             uzder(1,3,2)= dc_norm(2,i)
2956             uzder(2,3,2)=-dc_norm(1,i)
2957             uzder(3,3,2)= 0.0d0
2958             endif
2959 C Compute the Y-axis
2960             facy=fac
2961             do k=1,3
2962               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2963             enddo
2964             if (calc_grad) then
2965 C Compute the derivatives of uy
2966             do j=1,3
2967               do k=1,3
2968                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2969      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2970                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2971               enddo
2972               uyder(j,j,1)=uyder(j,j,1)-costh
2973               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2974             enddo
2975             do j=1,2
2976               do k=1,3
2977                 do l=1,3
2978                   uygrad(l,k,j,i)=uyder(l,k,j)
2979                   uzgrad(l,k,j,i)=uzder(l,k,j)
2980                 enddo
2981               enddo
2982             enddo
2983             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2984             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2985             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2986             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2987           endif
2988           endif
2989       enddo
2990       if (calc_grad) then
2991       do i=1,nres-1
2992         vbld_inv_temp(1)=vbld_inv(i+1)
2993         if (i.lt.nres-1) then
2994           vbld_inv_temp(2)=vbld_inv(i+2)
2995         else
2996           vbld_inv_temp(2)=vbld_inv(i)
2997         endif
2998         do j=1,2
2999           do k=1,3
3000             do l=1,3
3001               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
3002               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
3003             enddo
3004           enddo
3005         enddo
3006       enddo
3007       endif
3008       return
3009       end
3010 C-----------------------------------------------------------------------------
3011       subroutine vec_and_deriv_test
3012       implicit real*8 (a-h,o-z)
3013       include 'DIMENSIONS'
3014       include 'DIMENSIONS.ZSCOPT'
3015       include 'COMMON.IOUNITS'
3016       include 'COMMON.GEO'
3017       include 'COMMON.VAR'
3018       include 'COMMON.LOCAL'
3019       include 'COMMON.CHAIN'
3020       include 'COMMON.VECTORS'
3021       dimension uyder(3,3,2),uzder(3,3,2)
3022 C Compute the local reference systems. For reference system (i), the
3023 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
3024 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
3025       do i=1,nres-1
3026           if (i.eq.nres-1) then
3027 C Case of the last full residue
3028 C Compute the Z-axis
3029             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
3030             costh=dcos(pi-theta(nres))
3031             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3032 c            write (iout,*) 'fac',fac,
3033 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3034             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3035             do k=1,3
3036               uz(k,i)=fac*uz(k,i)
3037             enddo
3038 C Compute the derivatives of uz
3039             uzder(1,1,1)= 0.0d0
3040             uzder(2,1,1)=-dc_norm(3,i-1)
3041             uzder(3,1,1)= dc_norm(2,i-1)
3042             uzder(1,2,1)= dc_norm(3,i-1)
3043             uzder(2,2,1)= 0.0d0
3044             uzder(3,2,1)=-dc_norm(1,i-1)
3045             uzder(1,3,1)=-dc_norm(2,i-1)
3046             uzder(2,3,1)= dc_norm(1,i-1)
3047             uzder(3,3,1)= 0.0d0
3048             uzder(1,1,2)= 0.0d0
3049             uzder(2,1,2)= dc_norm(3,i)
3050             uzder(3,1,2)=-dc_norm(2,i)
3051             uzder(1,2,2)=-dc_norm(3,i)
3052             uzder(2,2,2)= 0.0d0
3053             uzder(3,2,2)= dc_norm(1,i)
3054             uzder(1,3,2)= dc_norm(2,i)
3055             uzder(2,3,2)=-dc_norm(1,i)
3056             uzder(3,3,2)= 0.0d0
3057 C Compute the Y-axis
3058             do k=1,3
3059               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
3060             enddo
3061             facy=fac
3062             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
3063      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
3064      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
3065             do k=1,3
3066 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3067               uy(k,i)=
3068 c     &        facy*(
3069      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
3070      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
3071 c     &        )
3072             enddo
3073 c            write (iout,*) 'facy',facy,
3074 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3075             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3076             do k=1,3
3077               uy(k,i)=facy*uy(k,i)
3078             enddo
3079 C Compute the derivatives of uy
3080             do j=1,3
3081               do k=1,3
3082                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
3083      &                        -dc_norm(k,i)*dc_norm(j,i-1)
3084                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3085               enddo
3086 c              uyder(j,j,1)=uyder(j,j,1)-costh
3087 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
3088               uyder(j,j,1)=uyder(j,j,1)
3089      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
3090               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
3091      &          +uyder(j,j,2)
3092             enddo
3093             do j=1,2
3094               do k=1,3
3095                 do l=1,3
3096                   uygrad(l,k,j,i)=uyder(l,k,j)
3097                   uzgrad(l,k,j,i)=uzder(l,k,j)
3098                 enddo
3099               enddo
3100             enddo
3101             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3102             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3103             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3104             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3105           else
3106 C Other residues
3107 C Compute the Z-axis
3108             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
3109             costh=dcos(pi-theta(i+2))
3110             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3111             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3112             do k=1,3
3113               uz(k,i)=fac*uz(k,i)
3114             enddo
3115 C Compute the derivatives of uz
3116             uzder(1,1,1)= 0.0d0
3117             uzder(2,1,1)=-dc_norm(3,i+1)
3118             uzder(3,1,1)= dc_norm(2,i+1)
3119             uzder(1,2,1)= dc_norm(3,i+1)
3120             uzder(2,2,1)= 0.0d0
3121             uzder(3,2,1)=-dc_norm(1,i+1)
3122             uzder(1,3,1)=-dc_norm(2,i+1)
3123             uzder(2,3,1)= dc_norm(1,i+1)
3124             uzder(3,3,1)= 0.0d0
3125             uzder(1,1,2)= 0.0d0
3126             uzder(2,1,2)= dc_norm(3,i)
3127             uzder(3,1,2)=-dc_norm(2,i)
3128             uzder(1,2,2)=-dc_norm(3,i)
3129             uzder(2,2,2)= 0.0d0
3130             uzder(3,2,2)= dc_norm(1,i)
3131             uzder(1,3,2)= dc_norm(2,i)
3132             uzder(2,3,2)=-dc_norm(1,i)
3133             uzder(3,3,2)= 0.0d0
3134 C Compute the Y-axis
3135             facy=fac
3136             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
3137      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
3138      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
3139             do k=1,3
3140 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3141               uy(k,i)=
3142 c     &        facy*(
3143      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
3144      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
3145 c     &        )
3146             enddo
3147 c            write (iout,*) 'facy',facy,
3148 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3149             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3150             do k=1,3
3151               uy(k,i)=facy*uy(k,i)
3152             enddo
3153 C Compute the derivatives of uy
3154             do j=1,3
3155               do k=1,3
3156                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
3157      &                        -dc_norm(k,i)*dc_norm(j,i+1)
3158                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3159               enddo
3160 c              uyder(j,j,1)=uyder(j,j,1)-costh
3161 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
3162               uyder(j,j,1)=uyder(j,j,1)
3163      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
3164               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
3165      &          +uyder(j,j,2)
3166             enddo
3167             do j=1,2
3168               do k=1,3
3169                 do l=1,3
3170                   uygrad(l,k,j,i)=uyder(l,k,j)
3171                   uzgrad(l,k,j,i)=uzder(l,k,j)
3172                 enddo
3173               enddo
3174             enddo
3175             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3176             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3177             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3178             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3179           endif
3180       enddo
3181       do i=1,nres-1
3182         do j=1,2
3183           do k=1,3
3184             do l=1,3
3185               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
3186               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
3187             enddo
3188           enddo
3189         enddo
3190       enddo
3191       return
3192       end
3193 C-----------------------------------------------------------------------------
3194       subroutine check_vecgrad
3195       implicit real*8 (a-h,o-z)
3196       include 'DIMENSIONS'
3197       include 'DIMENSIONS.ZSCOPT'
3198       include 'COMMON.IOUNITS'
3199       include 'COMMON.GEO'
3200       include 'COMMON.VAR'
3201       include 'COMMON.LOCAL'
3202       include 'COMMON.CHAIN'
3203       include 'COMMON.VECTORS'
3204       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
3205       dimension uyt(3,maxres),uzt(3,maxres)
3206       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
3207       double precision delta /1.0d-7/
3208       call vec_and_deriv
3209 cd      do i=1,nres
3210 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
3211 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
3212 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
3213 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
3214 cd     &     (dc_norm(if90,i),if90=1,3)
3215 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
3216 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
3217 cd          write(iout,'(a)')
3218 cd      enddo
3219       do i=1,nres
3220         do j=1,2
3221           do k=1,3
3222             do l=1,3
3223               uygradt(l,k,j,i)=uygrad(l,k,j,i)
3224               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
3225             enddo
3226           enddo
3227         enddo
3228       enddo
3229       call vec_and_deriv
3230       do i=1,nres
3231         do j=1,3
3232           uyt(j,i)=uy(j,i)
3233           uzt(j,i)=uz(j,i)
3234         enddo
3235       enddo
3236       do i=1,nres
3237 cd        write (iout,*) 'i=',i
3238         do k=1,3
3239           erij(k)=dc_norm(k,i)
3240         enddo
3241         do j=1,3
3242           do k=1,3
3243             dc_norm(k,i)=erij(k)
3244           enddo
3245           dc_norm(j,i)=dc_norm(j,i)+delta
3246 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
3247 c          do k=1,3
3248 c            dc_norm(k,i)=dc_norm(k,i)/fac
3249 c          enddo
3250 c          write (iout,*) (dc_norm(k,i),k=1,3)
3251 c          write (iout,*) (erij(k),k=1,3)
3252           call vec_and_deriv
3253           do k=1,3
3254             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
3255             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
3256             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
3257             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
3258           enddo
3259 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3260 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
3261 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
3262         enddo
3263         do k=1,3
3264           dc_norm(k,i)=erij(k)
3265         enddo
3266 cd        do k=1,3
3267 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3268 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
3269 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
3270 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3271 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
3272 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
3273 cd          write (iout,'(a)')
3274 cd        enddo
3275       enddo
3276       return
3277       end
3278 C--------------------------------------------------------------------------
3279       subroutine set_matrices
3280       implicit real*8 (a-h,o-z)
3281       include 'DIMENSIONS'
3282       include 'DIMENSIONS.ZSCOPT'
3283       include 'COMMON.IOUNITS'
3284       include 'COMMON.GEO'
3285       include 'COMMON.VAR'
3286       include 'COMMON.LOCAL'
3287       include 'COMMON.CHAIN'
3288       include 'COMMON.DERIV'
3289       include 'COMMON.INTERACT'
3290       include 'COMMON.CONTACTS'
3291       include 'COMMON.TORSION'
3292       include 'COMMON.VECTORS'
3293       include 'COMMON.FFIELD'
3294       double precision auxvec(2),auxmat(2,2)
3295 C
3296 C Compute the virtual-bond-torsional-angle dependent quantities needed
3297 C to calculate the el-loc multibody terms of various order.
3298 C
3299       do i=3,nres+1
3300         if (i .lt. nres+1) then
3301           sin1=dsin(phi(i))
3302           cos1=dcos(phi(i))
3303           sintab(i-2)=sin1
3304           costab(i-2)=cos1
3305           obrot(1,i-2)=cos1
3306           obrot(2,i-2)=sin1
3307           sin2=dsin(2*phi(i))
3308           cos2=dcos(2*phi(i))
3309           sintab2(i-2)=sin2
3310           costab2(i-2)=cos2
3311           obrot2(1,i-2)=cos2
3312           obrot2(2,i-2)=sin2
3313           Ug(1,1,i-2)=-cos1
3314           Ug(1,2,i-2)=-sin1
3315           Ug(2,1,i-2)=-sin1
3316           Ug(2,2,i-2)= cos1
3317           Ug2(1,1,i-2)=-cos2
3318           Ug2(1,2,i-2)=-sin2
3319           Ug2(2,1,i-2)=-sin2
3320           Ug2(2,2,i-2)= cos2
3321         else
3322           costab(i-2)=1.0d0
3323           sintab(i-2)=0.0d0
3324           obrot(1,i-2)=1.0d0
3325           obrot(2,i-2)=0.0d0
3326           obrot2(1,i-2)=0.0d0
3327           obrot2(2,i-2)=0.0d0
3328           Ug(1,1,i-2)=1.0d0
3329           Ug(1,2,i-2)=0.0d0
3330           Ug(2,1,i-2)=0.0d0
3331           Ug(2,2,i-2)=1.0d0
3332           Ug2(1,1,i-2)=0.0d0
3333           Ug2(1,2,i-2)=0.0d0
3334           Ug2(2,1,i-2)=0.0d0
3335           Ug2(2,2,i-2)=0.0d0
3336         endif
3337         if (i .gt. 3 .and. i .lt. nres+1) then
3338           obrot_der(1,i-2)=-sin1
3339           obrot_der(2,i-2)= cos1
3340           Ugder(1,1,i-2)= sin1
3341           Ugder(1,2,i-2)=-cos1
3342           Ugder(2,1,i-2)=-cos1
3343           Ugder(2,2,i-2)=-sin1
3344           dwacos2=cos2+cos2
3345           dwasin2=sin2+sin2
3346           obrot2_der(1,i-2)=-dwasin2
3347           obrot2_der(2,i-2)= dwacos2
3348           Ug2der(1,1,i-2)= dwasin2
3349           Ug2der(1,2,i-2)=-dwacos2
3350           Ug2der(2,1,i-2)=-dwacos2
3351           Ug2der(2,2,i-2)=-dwasin2
3352         else
3353           obrot_der(1,i-2)=0.0d0
3354           obrot_der(2,i-2)=0.0d0
3355           Ugder(1,1,i-2)=0.0d0
3356           Ugder(1,2,i-2)=0.0d0
3357           Ugder(2,1,i-2)=0.0d0
3358           Ugder(2,2,i-2)=0.0d0
3359           obrot2_der(1,i-2)=0.0d0
3360           obrot2_der(2,i-2)=0.0d0
3361           Ug2der(1,1,i-2)=0.0d0
3362           Ug2der(1,2,i-2)=0.0d0
3363           Ug2der(2,1,i-2)=0.0d0
3364           Ug2der(2,2,i-2)=0.0d0
3365         endif
3366         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3367           iti = itortyp(itype(i-2))
3368         else
3369           iti=ntortyp+1
3370         endif
3371         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3372           iti1 = itortyp(itype(i-1))
3373         else
3374           iti1=ntortyp+1
3375         endif
3376 cd        write (iout,*) '*******i',i,' iti1',iti
3377 cd        write (iout,*) 'b1',b1(:,iti)
3378 cd        write (iout,*) 'b2',b2(:,iti)
3379 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3380         if (i .gt. iatel_s+2) then
3381           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
3382           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
3383           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3384           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3385           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3386           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3387           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3388         else
3389           do k=1,2
3390             Ub2(k,i-2)=0.0d0
3391             Ctobr(k,i-2)=0.0d0
3392             Dtobr2(k,i-2)=0.0d0
3393             do l=1,2
3394               EUg(l,k,i-2)=0.0d0
3395               CUg(l,k,i-2)=0.0d0
3396               DUg(l,k,i-2)=0.0d0
3397               DtUg2(l,k,i-2)=0.0d0
3398             enddo
3399           enddo
3400         endif
3401         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
3402         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
3403         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3404         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3405         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3406         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3407         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3408         do k=1,2
3409           muder(k,i-2)=Ub2der(k,i-2)
3410         enddo
3411         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3412           iti1 = itortyp(itype(i-1))
3413         else
3414           iti1=ntortyp+1
3415         endif
3416         do k=1,2
3417           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
3418         enddo
3419 C Vectors and matrices dependent on a single virtual-bond dihedral.
3420         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
3421         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3422         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3423         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3424         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3425         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3426         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3427         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3428         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3429 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
3430 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
3431       enddo
3432 C Matrices dependent on two consecutive virtual-bond dihedrals.
3433 C The order of matrices is from left to right.
3434       do i=2,nres-1
3435         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3436         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3437         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3438         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3439         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3440         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3441         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3442         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3443       enddo
3444 cd      do i=1,nres
3445 cd        iti = itortyp(itype(i))
3446 cd        write (iout,*) i
3447 cd        do j=1,2
3448 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3449 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3450 cd        enddo
3451 cd      enddo
3452       return
3453       end
3454 C--------------------------------------------------------------------------
3455       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3456 C
3457 C This subroutine calculates the average interaction energy and its gradient
3458 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3459 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3460 C The potential depends both on the distance of peptide-group centers and on
3461 C the orientation of the CA-CA virtual bonds.
3462 C
3463       implicit real*8 (a-h,o-z)
3464       include 'DIMENSIONS'
3465       include 'DIMENSIONS.ZSCOPT'
3466       include 'COMMON.CONTROL'
3467       include 'COMMON.IOUNITS'
3468       include 'COMMON.GEO'
3469       include 'COMMON.VAR'
3470       include 'COMMON.LOCAL'
3471       include 'COMMON.CHAIN'
3472       include 'COMMON.DERIV'
3473       include 'COMMON.INTERACT'
3474       include 'COMMON.CONTACTS'
3475       include 'COMMON.TORSION'
3476       include 'COMMON.VECTORS'
3477       include 'COMMON.FFIELD'
3478       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3479      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3480       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3481      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3482       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
3483 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3484       double precision scal_el /0.5d0/
3485 C 12/13/98
3486 C 13-go grudnia roku pamietnego...
3487       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3488      &                   0.0d0,1.0d0,0.0d0,
3489      &                   0.0d0,0.0d0,1.0d0/
3490 cd      write(iout,*) 'In EELEC'
3491 cd      do i=1,nloctyp
3492 cd        write(iout,*) 'Type',i
3493 cd        write(iout,*) 'B1',B1(:,i)
3494 cd        write(iout,*) 'B2',B2(:,i)
3495 cd        write(iout,*) 'CC',CC(:,:,i)
3496 cd        write(iout,*) 'DD',DD(:,:,i)
3497 cd        write(iout,*) 'EE',EE(:,:,i)
3498 cd      enddo
3499 cd      call check_vecgrad
3500 cd      stop
3501       if (icheckgrad.eq.1) then
3502         do i=1,nres-1
3503           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3504           do k=1,3
3505             dc_norm(k,i)=dc(k,i)*fac
3506           enddo
3507 c          write (iout,*) 'i',i,' fac',fac
3508         enddo
3509       endif
3510       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3511      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3512      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3513 cd      if (wel_loc.gt.0.0d0) then
3514         if (icheckgrad.eq.1) then
3515         call vec_and_deriv_test
3516         else
3517         call vec_and_deriv
3518         endif
3519         call set_matrices
3520       endif
3521 cd      do i=1,nres-1
3522 cd        write (iout,*) 'i=',i
3523 cd        do k=1,3
3524 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3525 cd        enddo
3526 cd        do k=1,3
3527 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3528 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3529 cd        enddo
3530 cd      enddo
3531       num_conti_hb=0
3532       ees=0.0D0
3533       evdw1=0.0D0
3534       eel_loc=0.0d0
3535       eello_turn3=0.0d0
3536       eello_turn4=0.0d0
3537       ind=0
3538       do i=1,nres
3539         num_cont_hb(i)=0
3540       enddo
3541 cd      print '(a)','Enter EELEC'
3542 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3543       do i=1,nres
3544         gel_loc_loc(i)=0.0d0
3545         gcorr_loc(i)=0.0d0
3546       enddo
3547       do i=iatel_s,iatel_e
3548         if (itel(i).eq.0) goto 1215
3549         dxi=dc(1,i)
3550         dyi=dc(2,i)
3551         dzi=dc(3,i)
3552         dx_normi=dc_norm(1,i)
3553         dy_normi=dc_norm(2,i)
3554         dz_normi=dc_norm(3,i)
3555         xmedi=c(1,i)+0.5d0*dxi
3556         ymedi=c(2,i)+0.5d0*dyi
3557         zmedi=c(3,i)+0.5d0*dzi
3558         num_conti=0
3559 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3560         do j=ielstart(i),ielend(i)
3561           if (itel(j).eq.0) goto 1216
3562           ind=ind+1
3563           iteli=itel(i)
3564           itelj=itel(j)
3565           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3566           aaa=app(iteli,itelj)
3567           bbb=bpp(iteli,itelj)
3568 C Diagnostics only!!!
3569 c         aaa=0.0D0
3570 c         bbb=0.0D0
3571 c         ael6i=0.0D0
3572 c         ael3i=0.0D0
3573 C End diagnostics
3574           ael6i=ael6(iteli,itelj)
3575           ael3i=ael3(iteli,itelj)
3576           dxj=dc(1,j)
3577           dyj=dc(2,j)
3578           dzj=dc(3,j)
3579           dx_normj=dc_norm(1,j)
3580           dy_normj=dc_norm(2,j)
3581           dz_normj=dc_norm(3,j)
3582           xj=c(1,j)+0.5D0*dxj-xmedi
3583           yj=c(2,j)+0.5D0*dyj-ymedi
3584           zj=c(3,j)+0.5D0*dzj-zmedi
3585           rij=xj*xj+yj*yj+zj*zj
3586           rrmij=1.0D0/rij
3587           rij=dsqrt(rij)
3588           rmij=1.0D0/rij
3589           r3ij=rrmij*rmij
3590           r6ij=r3ij*r3ij
3591           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3592           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3593           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3594           fac=cosa-3.0D0*cosb*cosg
3595           ev1=aaa*r6ij*r6ij
3596 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3597           if (j.eq.i+2) ev1=scal_el*ev1
3598           ev2=bbb*r6ij
3599           fac3=ael6i*r6ij
3600           fac4=ael3i*r3ij
3601           evdwij=ev1+ev2
3602           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3603           el2=fac4*fac
3604           eesij=el1+el2
3605 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
3606 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3607           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3608           ees=ees+eesij
3609           evdw1=evdw1+evdwij
3610 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3611 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3612 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3613 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3614 C
3615 C Calculate contributions to the Cartesian gradient.
3616 C
3617 #ifdef SPLITELE
3618           facvdw=-6*rrmij*(ev1+evdwij)
3619           facel=-3*rrmij*(el1+eesij)
3620           fac1=fac
3621           erij(1)=xj*rmij
3622           erij(2)=yj*rmij
3623           erij(3)=zj*rmij
3624           if (calc_grad) then
3625 *
3626 * Radial derivatives. First process both termini of the fragment (i,j)
3627 *
3628           ggg(1)=facel*xj
3629           ggg(2)=facel*yj
3630           ggg(3)=facel*zj
3631           do k=1,3
3632             ghalf=0.5D0*ggg(k)
3633             gelc(k,i)=gelc(k,i)+ghalf
3634             gelc(k,j)=gelc(k,j)+ghalf
3635           enddo
3636 *
3637 * Loop over residues i+1 thru j-1.
3638 *
3639           do k=i+1,j-1
3640             do l=1,3
3641               gelc(l,k)=gelc(l,k)+ggg(l)
3642             enddo
3643           enddo
3644           ggg(1)=facvdw*xj
3645           ggg(2)=facvdw*yj
3646           ggg(3)=facvdw*zj
3647           do k=1,3
3648             ghalf=0.5D0*ggg(k)
3649             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3650             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3651           enddo
3652 *
3653 * Loop over residues i+1 thru j-1.
3654 *
3655           do k=i+1,j-1
3656             do l=1,3
3657               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3658             enddo
3659           enddo
3660 #else
3661           facvdw=ev1+evdwij
3662           facel=el1+eesij
3663           fac1=fac
3664           fac=-3*rrmij*(facvdw+facvdw+facel)
3665           erij(1)=xj*rmij
3666           erij(2)=yj*rmij
3667           erij(3)=zj*rmij
3668           if (calc_grad) then
3669 *
3670 * Radial derivatives. First process both termini of the fragment (i,j)
3671 *
3672           ggg(1)=fac*xj
3673           ggg(2)=fac*yj
3674           ggg(3)=fac*zj
3675           do k=1,3
3676             ghalf=0.5D0*ggg(k)
3677             gelc(k,i)=gelc(k,i)+ghalf
3678             gelc(k,j)=gelc(k,j)+ghalf
3679           enddo
3680 *
3681 * Loop over residues i+1 thru j-1.
3682 *
3683           do k=i+1,j-1
3684             do l=1,3
3685               gelc(l,k)=gelc(l,k)+ggg(l)
3686             enddo
3687           enddo
3688 #endif
3689 *
3690 * Angular part
3691 *
3692           ecosa=2.0D0*fac3*fac1+fac4
3693           fac4=-3.0D0*fac4
3694           fac3=-6.0D0*fac3
3695           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3696           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3697           do k=1,3
3698             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3699             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3700           enddo
3701 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3702 cd   &          (dcosg(k),k=1,3)
3703           do k=1,3
3704             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3705           enddo
3706           do k=1,3
3707             ghalf=0.5D0*ggg(k)
3708             gelc(k,i)=gelc(k,i)+ghalf
3709      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3710      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3711             gelc(k,j)=gelc(k,j)+ghalf
3712      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3713      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3714           enddo
3715           do k=i+1,j-1
3716             do l=1,3
3717               gelc(l,k)=gelc(l,k)+ggg(l)
3718             enddo
3719           enddo
3720           endif
3721
3722           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3723      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3724      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3725 C
3726 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3727 C   energy of a peptide unit is assumed in the form of a second-order
3728 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3729 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3730 C   are computed for EVERY pair of non-contiguous peptide groups.
3731 C
3732           if (j.lt.nres-1) then
3733             j1=j+1
3734             j2=j-1
3735           else
3736             j1=j-1
3737             j2=j-2
3738           endif
3739           kkk=0
3740           do k=1,2
3741             do l=1,2
3742               kkk=kkk+1
3743               muij(kkk)=mu(k,i)*mu(l,j)
3744             enddo
3745           enddo
3746 cd         write (iout,*) 'EELEC: i',i,' j',j
3747 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3748 cd          write(iout,*) 'muij',muij
3749           ury=scalar(uy(1,i),erij)
3750           urz=scalar(uz(1,i),erij)
3751           vry=scalar(uy(1,j),erij)
3752           vrz=scalar(uz(1,j),erij)
3753           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3754           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3755           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3756           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3757 C For diagnostics only
3758 cd          a22=1.0d0
3759 cd          a23=1.0d0
3760 cd          a32=1.0d0
3761 cd          a33=1.0d0
3762           fac=dsqrt(-ael6i)*r3ij
3763 cd          write (2,*) 'fac=',fac
3764 C For diagnostics only
3765 cd          fac=1.0d0
3766           a22=a22*fac
3767           a23=a23*fac
3768           a32=a32*fac
3769           a33=a33*fac
3770 cd          write (iout,'(4i5,4f10.5)')
3771 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3772 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3773 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
3774 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
3775 cd          write (iout,'(4f10.5)')
3776 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3777 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3778 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3779 cd           write (iout,'(2i3,9f10.5/)') i,j,
3780 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3781           if (calc_grad) then
3782 C Derivatives of the elements of A in virtual-bond vectors
3783           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3784 cd          do k=1,3
3785 cd            do l=1,3
3786 cd              erder(k,l)=0.0d0
3787 cd            enddo
3788 cd          enddo
3789           do k=1,3
3790             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3791             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3792             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3793             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3794             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3795             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3796             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3797             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3798             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3799             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3800             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3801             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3802           enddo
3803 cd          do k=1,3
3804 cd            do l=1,3
3805 cd              uryg(k,l)=0.0d0
3806 cd              urzg(k,l)=0.0d0
3807 cd              vryg(k,l)=0.0d0
3808 cd              vrzg(k,l)=0.0d0
3809 cd            enddo
3810 cd          enddo
3811 C Compute radial contributions to the gradient
3812           facr=-3.0d0*rrmij
3813           a22der=a22*facr
3814           a23der=a23*facr
3815           a32der=a32*facr
3816           a33der=a33*facr
3817 cd          a22der=0.0d0
3818 cd          a23der=0.0d0
3819 cd          a32der=0.0d0
3820 cd          a33der=0.0d0
3821           agg(1,1)=a22der*xj
3822           agg(2,1)=a22der*yj
3823           agg(3,1)=a22der*zj
3824           agg(1,2)=a23der*xj
3825           agg(2,2)=a23der*yj
3826           agg(3,2)=a23der*zj
3827           agg(1,3)=a32der*xj
3828           agg(2,3)=a32der*yj
3829           agg(3,3)=a32der*zj
3830           agg(1,4)=a33der*xj
3831           agg(2,4)=a33der*yj
3832           agg(3,4)=a33der*zj
3833 C Add the contributions coming from er
3834           fac3=-3.0d0*fac
3835           do k=1,3
3836             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3837             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3838             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3839             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3840           enddo
3841           do k=1,3
3842 C Derivatives in DC(i)
3843             ghalf1=0.5d0*agg(k,1)
3844             ghalf2=0.5d0*agg(k,2)
3845             ghalf3=0.5d0*agg(k,3)
3846             ghalf4=0.5d0*agg(k,4)
3847             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3848      &      -3.0d0*uryg(k,2)*vry)+ghalf1
3849             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3850      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
3851             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3852      &      -3.0d0*urzg(k,2)*vry)+ghalf3
3853             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3854      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
3855 C Derivatives in DC(i+1)
3856             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3857      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
3858             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3859      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
3860             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3861      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
3862             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3863      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
3864 C Derivatives in DC(j)
3865             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3866      &      -3.0d0*vryg(k,2)*ury)+ghalf1
3867             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3868      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
3869             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3870      &      -3.0d0*vryg(k,2)*urz)+ghalf3
3871             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3872      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
3873 C Derivatives in DC(j+1) or DC(nres-1)
3874             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3875      &      -3.0d0*vryg(k,3)*ury)
3876             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3877      &      -3.0d0*vrzg(k,3)*ury)
3878             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3879      &      -3.0d0*vryg(k,3)*urz)
3880             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3881      &      -3.0d0*vrzg(k,3)*urz)
3882 cd            aggi(k,1)=ghalf1
3883 cd            aggi(k,2)=ghalf2
3884 cd            aggi(k,3)=ghalf3
3885 cd            aggi(k,4)=ghalf4
3886 C Derivatives in DC(i+1)
3887 cd            aggi1(k,1)=agg(k,1)
3888 cd            aggi1(k,2)=agg(k,2)
3889 cd            aggi1(k,3)=agg(k,3)
3890 cd            aggi1(k,4)=agg(k,4)
3891 C Derivatives in DC(j)
3892 cd            aggj(k,1)=ghalf1
3893 cd            aggj(k,2)=ghalf2
3894 cd            aggj(k,3)=ghalf3
3895 cd            aggj(k,4)=ghalf4
3896 C Derivatives in DC(j+1)
3897 cd            aggj1(k,1)=0.0d0
3898 cd            aggj1(k,2)=0.0d0
3899 cd            aggj1(k,3)=0.0d0
3900 cd            aggj1(k,4)=0.0d0
3901             if (j.eq.nres-1 .and. i.lt.j-2) then
3902               do l=1,4
3903                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
3904 cd                aggj1(k,l)=agg(k,l)
3905               enddo
3906             endif
3907           enddo
3908           endif
3909 c          goto 11111
3910 C Check the loc-el terms by numerical integration
3911           acipa(1,1)=a22
3912           acipa(1,2)=a23
3913           acipa(2,1)=a32
3914           acipa(2,2)=a33
3915           a22=-a22
3916           a23=-a23
3917           do l=1,2
3918             do k=1,3
3919               agg(k,l)=-agg(k,l)
3920               aggi(k,l)=-aggi(k,l)
3921               aggi1(k,l)=-aggi1(k,l)
3922               aggj(k,l)=-aggj(k,l)
3923               aggj1(k,l)=-aggj1(k,l)
3924             enddo
3925           enddo
3926           if (j.lt.nres-1) then
3927             a22=-a22
3928             a32=-a32
3929             do l=1,3,2
3930               do k=1,3
3931                 agg(k,l)=-agg(k,l)
3932                 aggi(k,l)=-aggi(k,l)
3933                 aggi1(k,l)=-aggi1(k,l)
3934                 aggj(k,l)=-aggj(k,l)
3935                 aggj1(k,l)=-aggj1(k,l)
3936               enddo
3937             enddo
3938           else
3939             a22=-a22
3940             a23=-a23
3941             a32=-a32
3942             a33=-a33
3943             do l=1,4
3944               do k=1,3
3945                 agg(k,l)=-agg(k,l)
3946                 aggi(k,l)=-aggi(k,l)
3947                 aggi1(k,l)=-aggi1(k,l)
3948                 aggj(k,l)=-aggj(k,l)
3949                 aggj1(k,l)=-aggj1(k,l)
3950               enddo
3951             enddo
3952           endif
3953           ENDIF ! WCORR
3954 11111     continue
3955           IF (wel_loc.gt.0.0d0) THEN
3956 C Contribution to the local-electrostatic energy coming from the i-j pair
3957           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3958      &     +a33*muij(4)
3959 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3960 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3961           eel_loc=eel_loc+eel_loc_ij
3962 C Partial derivatives in virtual-bond dihedral angles gamma
3963           if (calc_grad) then
3964           if (i.gt.1)
3965      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3966      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3967      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3968           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3969      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3970      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3971 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
3972 cd          write(iout,*) 'agg  ',agg
3973 cd          write(iout,*) 'aggi ',aggi
3974 cd          write(iout,*) 'aggi1',aggi1
3975 cd          write(iout,*) 'aggj ',aggj
3976 cd          write(iout,*) 'aggj1',aggj1
3977
3978 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3979           do l=1,3
3980             ggg(l)=agg(l,1)*muij(1)+
3981      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3982           enddo
3983           do k=i+2,j2
3984             do l=1,3
3985               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3986             enddo
3987           enddo
3988 C Remaining derivatives of eello
3989           do l=1,3
3990             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3991      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3992             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3993      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3994             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3995      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3996             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3997      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3998           enddo
3999           endif
4000           ENDIF
4001           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4002 C Contributions from turns
4003             a_temp(1,1)=a22
4004             a_temp(1,2)=a23
4005             a_temp(2,1)=a32
4006             a_temp(2,2)=a33
4007             call eturn34(i,j,eello_turn3,eello_turn4)
4008           endif
4009 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4010           if (j.gt.i+1 .and. num_conti.le.maxconts) then
4011 C
4012 C Calculate the contact function. The ith column of the array JCONT will
4013 C contain the numbers of atoms that make contacts with the atom I (of numbers
4014 C greater than I). The arrays FACONT and GACONT will contain the values of
4015 C the contact function and its derivative.
4016 c           r0ij=1.02D0*rpp(iteli,itelj)
4017 c           r0ij=1.11D0*rpp(iteli,itelj)
4018             r0ij=2.20D0*rpp(iteli,itelj)
4019 c           r0ij=1.55D0*rpp(iteli,itelj)
4020             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4021             if (fcont.gt.0.0D0) then
4022               num_conti=num_conti+1
4023               if (num_conti.gt.maxconts) then
4024                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4025      &                         ' will skip next contacts for this conf.'
4026               else
4027                 jcont_hb(num_conti,i)=j
4028                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4029      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4030 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4031 C  terms.
4032                 d_cont(num_conti,i)=rij
4033 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4034 C     --- Electrostatic-interaction matrix ---
4035                 a_chuj(1,1,num_conti,i)=a22
4036                 a_chuj(1,2,num_conti,i)=a23
4037                 a_chuj(2,1,num_conti,i)=a32
4038                 a_chuj(2,2,num_conti,i)=a33
4039 C     --- Gradient of rij
4040                 do kkk=1,3
4041                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4042                 enddo
4043 c             if (i.eq.1) then
4044 c                a_chuj(1,1,num_conti,i)=-0.61d0
4045 c                a_chuj(1,2,num_conti,i)= 0.4d0
4046 c                a_chuj(2,1,num_conti,i)= 0.65d0
4047 c                a_chuj(2,2,num_conti,i)= 0.50d0
4048 c             else if (i.eq.2) then
4049 c                a_chuj(1,1,num_conti,i)= 0.0d0
4050 c                a_chuj(1,2,num_conti,i)= 0.0d0
4051 c                a_chuj(2,1,num_conti,i)= 0.0d0
4052 c                a_chuj(2,2,num_conti,i)= 0.0d0
4053 c             endif
4054 C     --- and its gradients
4055 cd                write (iout,*) 'i',i,' j',j
4056 cd                do kkk=1,3
4057 cd                write (iout,*) 'iii 1 kkk',kkk
4058 cd                write (iout,*) agg(kkk,:)
4059 cd                enddo
4060 cd                do kkk=1,3
4061 cd                write (iout,*) 'iii 2 kkk',kkk
4062 cd                write (iout,*) aggi(kkk,:)
4063 cd                enddo
4064 cd                do kkk=1,3
4065 cd                write (iout,*) 'iii 3 kkk',kkk
4066 cd                write (iout,*) aggi1(kkk,:)
4067 cd                enddo
4068 cd                do kkk=1,3
4069 cd                write (iout,*) 'iii 4 kkk',kkk
4070 cd                write (iout,*) aggj(kkk,:)
4071 cd                enddo
4072 cd                do kkk=1,3
4073 cd                write (iout,*) 'iii 5 kkk',kkk
4074 cd                write (iout,*) aggj1(kkk,:)
4075 cd                enddo
4076                 kkll=0
4077                 do k=1,2
4078                   do l=1,2
4079                     kkll=kkll+1
4080                     do m=1,3
4081                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4082                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4083                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4084                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4085                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4086 c                      do mm=1,5
4087 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
4088 c                      enddo
4089                     enddo
4090                   enddo
4091                 enddo
4092                 ENDIF
4093                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4094 C Calculate contact energies
4095                 cosa4=4.0D0*cosa
4096                 wij=cosa-3.0D0*cosb*cosg
4097                 cosbg1=cosb+cosg
4098                 cosbg2=cosb-cosg
4099 c               fac3=dsqrt(-ael6i)/r0ij**3
4100                 fac3=dsqrt(-ael6i)*r3ij
4101                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4102                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4103 c               ees0mij=0.0D0
4104                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4105                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4106 C Diagnostics. Comment out or remove after debugging!
4107 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4108 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4109 c               ees0m(num_conti,i)=0.0D0
4110 C End diagnostics.
4111 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4112 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4113                 facont_hb(num_conti,i)=fcont
4114                 if (calc_grad) then
4115 C Angular derivatives of the contact function
4116                 ees0pij1=fac3/ees0pij
4117                 ees0mij1=fac3/ees0mij
4118                 fac3p=-3.0D0*fac3*rrmij
4119                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4120                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4121 c               ees0mij1=0.0D0
4122                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4123                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4124                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4125                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4126                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4127                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4128                 ecosap=ecosa1+ecosa2
4129                 ecosbp=ecosb1+ecosb2
4130                 ecosgp=ecosg1+ecosg2
4131                 ecosam=ecosa1-ecosa2
4132                 ecosbm=ecosb1-ecosb2
4133                 ecosgm=ecosg1-ecosg2
4134 C Diagnostics
4135 c               ecosap=ecosa1
4136 c               ecosbp=ecosb1
4137 c               ecosgp=ecosg1
4138 c               ecosam=0.0D0
4139 c               ecosbm=0.0D0
4140 c               ecosgm=0.0D0
4141 C End diagnostics
4142                 fprimcont=fprimcont/rij
4143 cd              facont_hb(num_conti,i)=1.0D0
4144 C Following line is for diagnostics.
4145 cd              fprimcont=0.0D0
4146                 do k=1,3
4147                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4148                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4149                 enddo
4150                 do k=1,3
4151                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4152                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4153                 enddo
4154                 gggp(1)=gggp(1)+ees0pijp*xj
4155                 gggp(2)=gggp(2)+ees0pijp*yj
4156                 gggp(3)=gggp(3)+ees0pijp*zj
4157                 gggm(1)=gggm(1)+ees0mijp*xj
4158                 gggm(2)=gggm(2)+ees0mijp*yj
4159                 gggm(3)=gggm(3)+ees0mijp*zj
4160 C Derivatives due to the contact function
4161                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4162                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4163                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4164                 do k=1,3
4165                   ghalfp=0.5D0*gggp(k)
4166                   ghalfm=0.5D0*gggm(k)
4167                   gacontp_hb1(k,num_conti,i)=ghalfp
4168      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4169      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4170                   gacontp_hb2(k,num_conti,i)=ghalfp
4171      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4172      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4173                   gacontp_hb3(k,num_conti,i)=gggp(k)
4174                   gacontm_hb1(k,num_conti,i)=ghalfm
4175      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4176      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4177                   gacontm_hb2(k,num_conti,i)=ghalfm
4178      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4179      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4180                   gacontm_hb3(k,num_conti,i)=gggm(k)
4181                 enddo
4182                 endif
4183 C Diagnostics. Comment out or remove after debugging!
4184 cdiag           do k=1,3
4185 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4186 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4187 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4188 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4189 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4190 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4191 cdiag           enddo
4192               ENDIF ! wcorr
4193               endif  ! num_conti.le.maxconts
4194             endif  ! fcont.gt.0
4195           endif    ! j.gt.i+1
4196  1216     continue
4197         enddo ! j
4198         num_cont_hb(i)=num_conti
4199  1215   continue
4200       enddo   ! i
4201 cd      do i=1,nres
4202 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
4203 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
4204 cd      enddo
4205 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
4206 ccc      eel_loc=eel_loc+eello_turn3
4207       return
4208       end
4209 C-----------------------------------------------------------------------------
4210       subroutine eturn34(i,j,eello_turn3,eello_turn4)
4211 C Third- and fourth-order contributions from turns
4212       implicit real*8 (a-h,o-z)
4213       include 'DIMENSIONS'
4214       include 'DIMENSIONS.ZSCOPT'
4215       include 'COMMON.IOUNITS'
4216       include 'COMMON.GEO'
4217       include 'COMMON.VAR'
4218       include 'COMMON.LOCAL'
4219       include 'COMMON.CHAIN'
4220       include 'COMMON.DERIV'
4221       include 'COMMON.INTERACT'
4222       include 'COMMON.CONTACTS'
4223       include 'COMMON.TORSION'
4224       include 'COMMON.VECTORS'
4225       include 'COMMON.FFIELD'
4226       dimension ggg(3)
4227       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4228      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4229      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
4230       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4231      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
4232       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
4233       if (j.eq.i+2) then
4234 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4235 C
4236 C               Third-order contributions
4237 C
4238 C                 (i+2)o----(i+3)
4239 C                      | |
4240 C                      | |
4241 C                 (i+1)o----i
4242 C
4243 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4244 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4245         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4246         call transpose2(auxmat(1,1),auxmat1(1,1))
4247         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4248         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4249 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4250 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4251 cd     &    ' eello_turn3_num',4*eello_turn3_num
4252         if (calc_grad) then
4253 C Derivatives in gamma(i)
4254         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4255         call transpose2(auxmat2(1,1),pizda(1,1))
4256         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
4257         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4258 C Derivatives in gamma(i+1)
4259         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4260         call transpose2(auxmat2(1,1),pizda(1,1))
4261         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
4262         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4263      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4264 C Cartesian derivatives
4265         do l=1,3
4266           a_temp(1,1)=aggi(l,1)
4267           a_temp(1,2)=aggi(l,2)
4268           a_temp(2,1)=aggi(l,3)
4269           a_temp(2,2)=aggi(l,4)
4270           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4271           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4272      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4273           a_temp(1,1)=aggi1(l,1)
4274           a_temp(1,2)=aggi1(l,2)
4275           a_temp(2,1)=aggi1(l,3)
4276           a_temp(2,2)=aggi1(l,4)
4277           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4278           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4279      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4280           a_temp(1,1)=aggj(l,1)
4281           a_temp(1,2)=aggj(l,2)
4282           a_temp(2,1)=aggj(l,3)
4283           a_temp(2,2)=aggj(l,4)
4284           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4285           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4286      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4287           a_temp(1,1)=aggj1(l,1)
4288           a_temp(1,2)=aggj1(l,2)
4289           a_temp(2,1)=aggj1(l,3)
4290           a_temp(2,2)=aggj1(l,4)
4291           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4292           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4293      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4294         enddo
4295         endif
4296       else if (j.eq.i+3) then
4297 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4298 C
4299 C               Fourth-order contributions
4300 C
4301 C                 (i+3)o----(i+4)
4302 C                     /  |
4303 C               (i+2)o   |
4304 C                     \  |
4305 C                 (i+1)o----i
4306 C
4307 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4308 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4309         iti1=itortyp(itype(i+1))
4310         iti2=itortyp(itype(i+2))
4311         iti3=itortyp(itype(i+3))
4312         call transpose2(EUg(1,1,i+1),e1t(1,1))
4313         call transpose2(Eug(1,1,i+2),e2t(1,1))
4314         call transpose2(Eug(1,1,i+3),e3t(1,1))
4315         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4316         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4317         s1=scalar2(b1(1,iti2),auxvec(1))
4318         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4319         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4320         s2=scalar2(b1(1,iti1),auxvec(1))
4321         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4322         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4323         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4324         eello_turn4=eello_turn4-(s1+s2+s3)
4325 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4326 cd     &    ' eello_turn4_num',8*eello_turn4_num
4327 C Derivatives in gamma(i)
4328         if (calc_grad) then
4329         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4330         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4331         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4332         s1=scalar2(b1(1,iti2),auxvec(1))
4333         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4334         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4335         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4336 C Derivatives in gamma(i+1)
4337         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4338         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4339         s2=scalar2(b1(1,iti1),auxvec(1))
4340         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4341         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4342         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4343         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4344 C Derivatives in gamma(i+2)
4345         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4346         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4347         s1=scalar2(b1(1,iti2),auxvec(1))
4348         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4349         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4350         s2=scalar2(b1(1,iti1),auxvec(1))
4351         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
4352         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4353         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4354         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4355 C Cartesian derivatives
4356 C Derivatives of this turn contributions in DC(i+2)
4357         if (j.lt.nres-1) then
4358           do l=1,3
4359             a_temp(1,1)=agg(l,1)
4360             a_temp(1,2)=agg(l,2)
4361             a_temp(2,1)=agg(l,3)
4362             a_temp(2,2)=agg(l,4)
4363             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4364             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4365             s1=scalar2(b1(1,iti2),auxvec(1))
4366             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4367             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4368             s2=scalar2(b1(1,iti1),auxvec(1))
4369             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4370             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4371             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4372             ggg(l)=-(s1+s2+s3)
4373             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4374           enddo
4375         endif
4376 C Remaining derivatives of this turn contribution
4377         do l=1,3
4378           a_temp(1,1)=aggi(l,1)
4379           a_temp(1,2)=aggi(l,2)
4380           a_temp(2,1)=aggi(l,3)
4381           a_temp(2,2)=aggi(l,4)
4382           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4383           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4384           s1=scalar2(b1(1,iti2),auxvec(1))
4385           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4386           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4387           s2=scalar2(b1(1,iti1),auxvec(1))
4388           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4389           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4390           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4391           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4392           a_temp(1,1)=aggi1(l,1)
4393           a_temp(1,2)=aggi1(l,2)
4394           a_temp(2,1)=aggi1(l,3)
4395           a_temp(2,2)=aggi1(l,4)
4396           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4397           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4398           s1=scalar2(b1(1,iti2),auxvec(1))
4399           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4400           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4401           s2=scalar2(b1(1,iti1),auxvec(1))
4402           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4403           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4404           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4405           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4406           a_temp(1,1)=aggj(l,1)
4407           a_temp(1,2)=aggj(l,2)
4408           a_temp(2,1)=aggj(l,3)
4409           a_temp(2,2)=aggj(l,4)
4410           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4411           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4412           s1=scalar2(b1(1,iti2),auxvec(1))
4413           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4414           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4415           s2=scalar2(b1(1,iti1),auxvec(1))
4416           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4417           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4418           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4419           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4420           a_temp(1,1)=aggj1(l,1)
4421           a_temp(1,2)=aggj1(l,2)
4422           a_temp(2,1)=aggj1(l,3)
4423           a_temp(2,2)=aggj1(l,4)
4424           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4425           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4426           s1=scalar2(b1(1,iti2),auxvec(1))
4427           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4428           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4429           s2=scalar2(b1(1,iti1),auxvec(1))
4430           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4431           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4432           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4433           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4434         enddo
4435         endif
4436       endif
4437       return
4438       end
4439 C-----------------------------------------------------------------------------
4440       subroutine vecpr(u,v,w)
4441       implicit real*8(a-h,o-z)
4442       dimension u(3),v(3),w(3)
4443       w(1)=u(2)*v(3)-u(3)*v(2)
4444       w(2)=-u(1)*v(3)+u(3)*v(1)
4445       w(3)=u(1)*v(2)-u(2)*v(1)
4446       return
4447       end
4448 C-----------------------------------------------------------------------------
4449       subroutine unormderiv(u,ugrad,unorm,ungrad)
4450 C This subroutine computes the derivatives of a normalized vector u, given
4451 C the derivatives computed without normalization conditions, ugrad. Returns
4452 C ungrad.
4453       implicit none
4454       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4455       double precision vec(3)
4456       double precision scalar
4457       integer i,j
4458 c      write (2,*) 'ugrad',ugrad
4459 c      write (2,*) 'u',u
4460       do i=1,3
4461         vec(i)=scalar(ugrad(1,i),u(1))
4462       enddo
4463 c      write (2,*) 'vec',vec
4464       do i=1,3
4465         do j=1,3
4466           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4467         enddo
4468       enddo
4469 c      write (2,*) 'ungrad',ungrad
4470       return
4471       end
4472 C-----------------------------------------------------------------------------
4473       subroutine escp(evdw2,evdw2_14)
4474 C
4475 C This subroutine calculates the excluded-volume interaction energy between
4476 C peptide-group centers and side chains and its gradient in virtual-bond and
4477 C side-chain vectors.
4478 C
4479       implicit real*8 (a-h,o-z)
4480       include 'DIMENSIONS'
4481       include 'DIMENSIONS.ZSCOPT'
4482       include 'COMMON.GEO'
4483       include 'COMMON.VAR'
4484       include 'COMMON.LOCAL'
4485       include 'COMMON.CHAIN'
4486       include 'COMMON.DERIV'
4487       include 'COMMON.INTERACT'
4488       include 'COMMON.FFIELD'
4489       include 'COMMON.IOUNITS'
4490       dimension ggg(3)
4491       evdw2=0.0D0
4492       evdw2_14=0.0d0
4493 cd    print '(a)','Enter ESCP'
4494 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
4495 c     &  ' scal14',scal14
4496       do i=iatscp_s,iatscp_e
4497         iteli=itel(i)
4498 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
4499 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
4500         if (iteli.eq.0) goto 1225
4501         xi=0.5D0*(c(1,i)+c(1,i+1))
4502         yi=0.5D0*(c(2,i)+c(2,i+1))
4503         zi=0.5D0*(c(3,i)+c(3,i+1))
4504
4505         do iint=1,nscp_gr(i)
4506
4507         do j=iscpstart(i,iint),iscpend(i,iint)
4508           itypj=itype(j)
4509 C Uncomment following three lines for SC-p interactions
4510 c         xj=c(1,nres+j)-xi
4511 c         yj=c(2,nres+j)-yi
4512 c         zj=c(3,nres+j)-zi
4513 C Uncomment following three lines for Ca-p interactions
4514           xj=c(1,j)-xi
4515           yj=c(2,j)-yi
4516           zj=c(3,j)-zi
4517           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4518           fac=rrij**expon2
4519           e1=fac*fac*aad(itypj,iteli)
4520           e2=fac*bad(itypj,iteli)
4521           if (iabs(j-i) .le. 2) then
4522             e1=scal14*e1
4523             e2=scal14*e2
4524             evdw2_14=evdw2_14+e1+e2
4525           endif
4526           evdwij=e1+e2
4527 c          write (iout,*) i,j,evdwij
4528           evdw2=evdw2+evdwij
4529           if (calc_grad) then
4530 C
4531 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4532 C
4533           fac=-(evdwij+e1)*rrij
4534           ggg(1)=xj*fac
4535           ggg(2)=yj*fac
4536           ggg(3)=zj*fac
4537           if (j.lt.i) then
4538 cd          write (iout,*) 'j<i'
4539 C Uncomment following three lines for SC-p interactions
4540 c           do k=1,3
4541 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4542 c           enddo
4543           else
4544 cd          write (iout,*) 'j>i'
4545             do k=1,3
4546               ggg(k)=-ggg(k)
4547 C Uncomment following line for SC-p interactions
4548 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4549             enddo
4550           endif
4551           do k=1,3
4552             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4553           enddo
4554           kstart=min0(i+1,j)
4555           kend=max0(i-1,j-1)
4556 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4557 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4558           do k=kstart,kend
4559             do l=1,3
4560               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4561             enddo
4562           enddo
4563           endif
4564         enddo
4565         enddo ! iint
4566  1225   continue
4567       enddo ! i
4568       do i=1,nct
4569         do j=1,3
4570           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4571           gradx_scp(j,i)=expon*gradx_scp(j,i)
4572         enddo
4573       enddo
4574 C******************************************************************************
4575 C
4576 C                              N O T E !!!
4577 C
4578 C To save time the factor EXPON has been extracted from ALL components
4579 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4580 C use!
4581 C
4582 C******************************************************************************
4583       return
4584       end
4585 C--------------------------------------------------------------------------
4586       subroutine edis(ehpb)
4587 C
4588 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4589 C
4590       implicit real*8 (a-h,o-z)
4591       include 'DIMENSIONS'
4592       include 'COMMON.SBRIDGE'
4593       include 'COMMON.CHAIN'
4594       include 'COMMON.DERIV'
4595       include 'COMMON.VAR'
4596       include 'COMMON.INTERACT'
4597       include 'COMMON.IOUNITS'
4598       dimension ggg(3)
4599       ehpb=0.0D0
4600 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4601 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4602       if (link_end.eq.0) return
4603       do i=link_start,link_end
4604 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4605 C CA-CA distance used in regularization of structure.
4606         ii=ihpb(i)
4607         jj=jhpb(i)
4608 C iii and jjj point to the residues for which the distance is assigned.
4609         if (ii.gt.nres) then
4610           iii=ii-nres
4611           jjj=jj-nres
4612         else
4613           iii=ii
4614           jjj=jj
4615         endif
4616 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4617 c     &    dhpb(i),dhpb1(i),forcon(i)
4618 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4619 C    distance and angle dependent SS bond potential.
4620         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4621           call ssbond_ene(iii,jjj,eij)
4622           ehpb=ehpb+2*eij
4623 cd          write (iout,*) "eij",eij
4624         else if (ii.gt.nres .and. jj.gt.nres) then
4625 c Restraints from contact prediction
4626           dd=dist(ii,jj)
4627           if (dhpb1(i).gt.0.0d0) then
4628             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4629             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4630 c            write (iout,*) "beta nmr",
4631 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4632           else
4633             dd=dist(ii,jj)
4634             rdis=dd-dhpb(i)
4635 C Get the force constant corresponding to this distance.
4636             waga=forcon(i)
4637 C Calculate the contribution to energy.
4638             ehpb=ehpb+waga*rdis*rdis
4639 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4640 C
4641 C Evaluate gradient.
4642 C
4643             fac=waga*rdis/dd
4644           endif
4645           do j=1,3
4646             ggg(j)=fac*(c(j,jj)-c(j,ii))
4647           enddo
4648           do j=1,3
4649             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4650             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4651           enddo
4652           do k=1,3
4653             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4654             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4655           enddo
4656         else
4657 C Calculate the distance between the two points and its difference from the
4658 C target distance.
4659           dd=dist(ii,jj)
4660           if (dhpb1(i).gt.0.0d0) then
4661             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4662             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4663 c            write (iout,*) "alph nmr",
4664 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4665           else
4666             rdis=dd-dhpb(i)
4667 C Get the force constant corresponding to this distance.
4668             waga=forcon(i)
4669 C Calculate the contribution to energy.
4670             ehpb=ehpb+waga*rdis*rdis
4671 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4672 C
4673 C Evaluate gradient.
4674 C
4675             fac=waga*rdis/dd
4676           endif
4677 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4678 cd   &   ' waga=',waga,' fac=',fac
4679             do j=1,3
4680               ggg(j)=fac*(c(j,jj)-c(j,ii))
4681             enddo
4682 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4683 C If this is a SC-SC distance, we need to calculate the contributions to the
4684 C Cartesian gradient in the SC vectors (ghpbx).
4685           if (iii.lt.ii) then
4686           do j=1,3
4687             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4688             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4689           enddo
4690           endif
4691           do k=1,3
4692             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4693             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4694           enddo
4695         endif
4696       enddo
4697       ehpb=0.5D0*ehpb
4698       return
4699       end
4700 C--------------------------------------------------------------------------
4701       subroutine ssbond_ene(i,j,eij)
4702 C
4703 C Calculate the distance and angle dependent SS-bond potential energy
4704 C using a free-energy function derived based on RHF/6-31G** ab initio
4705 C calculations of diethyl disulfide.
4706 C
4707 C A. Liwo and U. Kozlowska, 11/24/03
4708 C
4709       implicit real*8 (a-h,o-z)
4710       include 'DIMENSIONS'
4711       include 'DIMENSIONS.ZSCOPT'
4712       include 'COMMON.SBRIDGE'
4713       include 'COMMON.CHAIN'
4714       include 'COMMON.DERIV'
4715       include 'COMMON.LOCAL'
4716       include 'COMMON.INTERACT'
4717       include 'COMMON.VAR'
4718       include 'COMMON.IOUNITS'
4719       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4720       itypi=itype(i)
4721       xi=c(1,nres+i)
4722       yi=c(2,nres+i)
4723       zi=c(3,nres+i)
4724       dxi=dc_norm(1,nres+i)
4725       dyi=dc_norm(2,nres+i)
4726       dzi=dc_norm(3,nres+i)
4727       dsci_inv=dsc_inv(itypi)
4728       itypj=itype(j)
4729       dscj_inv=dsc_inv(itypj)
4730       xj=c(1,nres+j)-xi
4731       yj=c(2,nres+j)-yi
4732       zj=c(3,nres+j)-zi
4733       dxj=dc_norm(1,nres+j)
4734       dyj=dc_norm(2,nres+j)
4735       dzj=dc_norm(3,nres+j)
4736       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4737       rij=dsqrt(rrij)
4738       erij(1)=xj*rij
4739       erij(2)=yj*rij
4740       erij(3)=zj*rij
4741       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4742       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4743       om12=dxi*dxj+dyi*dyj+dzi*dzj
4744       do k=1,3
4745         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4746         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4747       enddo
4748       rij=1.0d0/rij
4749       deltad=rij-d0cm
4750       deltat1=1.0d0-om1
4751       deltat2=1.0d0+om2
4752       deltat12=om2-om1+2.0d0
4753       cosphi=om12-om1*om2
4754       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4755      &  +akct*deltad*deltat12
4756      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4757 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4758 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4759 c     &  " deltat12",deltat12," eij",eij
4760       ed=2*akcm*deltad+akct*deltat12
4761       pom1=akct*deltad
4762       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4763       eom1=-2*akth*deltat1-pom1-om2*pom2
4764       eom2= 2*akth*deltat2+pom1-om1*pom2
4765       eom12=pom2
4766       do k=1,3
4767         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4768       enddo
4769       do k=1,3
4770         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4771      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4772         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4773      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4774       enddo
4775 C
4776 C Calculate the components of the gradient in DC and X
4777 C
4778       do k=i,j-1
4779         do l=1,3
4780           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4781         enddo
4782       enddo
4783       return
4784       end
4785 C--------------------------------------------------------------------------
4786       subroutine ebond(estr)
4787 c
4788 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4789 c
4790       implicit real*8 (a-h,o-z)
4791       include 'DIMENSIONS'
4792       include 'DIMENSIONS.ZSCOPT'
4793       include 'COMMON.LOCAL'
4794       include 'COMMON.GEO'
4795       include 'COMMON.INTERACT'
4796       include 'COMMON.DERIV'
4797       include 'COMMON.VAR'
4798       include 'COMMON.CHAIN'
4799       include 'COMMON.IOUNITS'
4800       include 'COMMON.NAMES'
4801       include 'COMMON.FFIELD'
4802       include 'COMMON.CONTROL'
4803       double precision u(3),ud(3)
4804       estr=0.0d0
4805       do i=nnt+1,nct
4806         diff = vbld(i)-vbldp0
4807 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4808         estr=estr+diff*diff
4809         do j=1,3
4810           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4811         enddo
4812       enddo
4813       estr=0.5d0*AKP*estr
4814 c
4815 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4816 c
4817       do i=nnt,nct
4818         iti=itype(i)
4819         if (iti.ne.10) then
4820           nbi=nbondterm(iti)
4821           if (nbi.eq.1) then
4822             diff=vbld(i+nres)-vbldsc0(1,iti)
4823             write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4824      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4825             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4826             do j=1,3
4827               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4828             enddo
4829           else
4830             do j=1,nbi
4831               diff=vbld(i+nres)-vbldsc0(j,iti)
4832               ud(j)=aksc(j,iti)*diff
4833               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4834             enddo
4835             uprod=u(1)
4836             do j=2,nbi
4837               uprod=uprod*u(j)
4838             enddo
4839             usum=0.0d0
4840             usumsqder=0.0d0
4841             do j=1,nbi
4842               uprod1=1.0d0
4843               uprod2=1.0d0
4844               do k=1,nbi
4845                 if (k.ne.j) then
4846                   uprod1=uprod1*u(k)
4847                   uprod2=uprod2*u(k)*u(k)
4848                 endif
4849               enddo
4850               usum=usum+uprod1
4851               usumsqder=usumsqder+ud(j)*uprod2
4852             enddo
4853             write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4854      &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4855             estr=estr+uprod/usum
4856             do j=1,3
4857              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4858             enddo
4859           endif
4860         endif
4861       enddo
4862       return
4863       end
4864 #ifdef CRYST_THETA
4865 C--------------------------------------------------------------------------
4866       subroutine ebend(etheta)
4867 C
4868 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4869 C angles gamma and its derivatives in consecutive thetas and gammas.
4870 C
4871       implicit real*8 (a-h,o-z)
4872       include 'DIMENSIONS'
4873       include 'DIMENSIONS.ZSCOPT'
4874       include 'COMMON.LOCAL'
4875       include 'COMMON.GEO'
4876       include 'COMMON.INTERACT'
4877       include 'COMMON.DERIV'
4878       include 'COMMON.VAR'
4879       include 'COMMON.CHAIN'
4880       include 'COMMON.IOUNITS'
4881       include 'COMMON.NAMES'
4882       include 'COMMON.FFIELD'
4883       common /calcthet/ term1,term2,termm,diffak,ratak,
4884      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4885      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4886       double precision y(2),z(2)
4887       delta=0.02d0*pi
4888       time11=dexp(-2*time)
4889       time12=1.0d0
4890       etheta=0.0D0
4891 c      write (iout,*) "nres",nres
4892 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4893 c      write (iout,*) ithet_start,ithet_end
4894       do i=ithet_start,ithet_end
4895 C Zero the energy function and its derivative at 0 or pi.
4896         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4897         it=itype(i-1)
4898 c        if (i.gt.ithet_start .and.
4899 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
4900 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
4901 c          phii=phi(i)
4902 c          y(1)=dcos(phii)
4903 c          y(2)=dsin(phii)
4904 c        else
4905 c          y(1)=0.0D0
4906 c          y(2)=0.0D0
4907 c        endif
4908 c        if (i.lt.nres .and. itel(i).ne.0) then
4909 c          phii1=phi(i+1)
4910 c          z(1)=dcos(phii1)
4911 c          z(2)=dsin(phii1)
4912 c        else
4913 c          z(1)=0.0D0
4914 c          z(2)=0.0D0
4915 c        endif
4916         if (i.gt.3) then
4917 #ifdef OSF
4918           phii=phi(i)
4919           icrc=0
4920           call proc_proc(phii,icrc)
4921           if (icrc.eq.1) phii=150.0
4922 #else
4923           phii=phi(i)
4924 #endif
4925           y(1)=dcos(phii)
4926           y(2)=dsin(phii)
4927         else
4928           y(1)=0.0D0
4929           y(2)=0.0D0
4930         endif
4931         if (i.lt.nres) then
4932 #ifdef OSF
4933           phii1=phi(i+1)
4934           icrc=0
4935           call proc_proc(phii1,icrc)
4936           if (icrc.eq.1) phii1=150.0
4937           phii1=pinorm(phii1)
4938           z(1)=cos(phii1)
4939 #else
4940           phii1=phi(i+1)
4941           z(1)=dcos(phii1)
4942 #endif
4943           z(2)=dsin(phii1)
4944         else
4945           z(1)=0.0D0
4946           z(2)=0.0D0
4947         endif
4948 C Calculate the "mean" value of theta from the part of the distribution
4949 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4950 C In following comments this theta will be referred to as t_c.
4951         thet_pred_mean=0.0d0
4952         do k=1,2
4953           athetk=athet(k,it)
4954           bthetk=bthet(k,it)
4955           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4956         enddo
4957 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4958         dthett=thet_pred_mean*ssd
4959         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4960 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4961 C Derivatives of the "mean" values in gamma1 and gamma2.
4962         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4963         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4964         if (theta(i).gt.pi-delta) then
4965           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4966      &         E_tc0)
4967           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4968           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4969           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4970      &        E_theta)
4971           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4972      &        E_tc)
4973         else if (theta(i).lt.delta) then
4974           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4975           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4976           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4977      &        E_theta)
4978           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4979           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4980      &        E_tc)
4981         else
4982           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4983      &        E_theta,E_tc)
4984         endif
4985         etheta=etheta+ethetai
4986 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4987 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4988         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4989         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4990         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4991  1215   continue
4992       enddo
4993 C Ufff.... We've done all this!!!
4994       return
4995       end
4996 C---------------------------------------------------------------------------
4997       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4998      &     E_tc)
4999       implicit real*8 (a-h,o-z)
5000       include 'DIMENSIONS'
5001       include 'COMMON.LOCAL'
5002       include 'COMMON.IOUNITS'
5003       common /calcthet/ term1,term2,termm,diffak,ratak,
5004      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5005      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5006 C Calculate the contributions to both Gaussian lobes.
5007 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5008 C The "polynomial part" of the "standard deviation" of this part of
5009 C the distribution.
5010         sig=polthet(3,it)
5011         do j=2,0,-1
5012           sig=sig*thet_pred_mean+polthet(j,it)
5013         enddo
5014 C Derivative of the "interior part" of the "standard deviation of the"
5015 C gamma-dependent Gaussian lobe in t_c.
5016         sigtc=3*polthet(3,it)
5017         do j=2,1,-1
5018           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5019         enddo
5020         sigtc=sig*sigtc
5021 C Set the parameters of both Gaussian lobes of the distribution.
5022 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5023         fac=sig*sig+sigc0(it)
5024         sigcsq=fac+fac
5025         sigc=1.0D0/sigcsq
5026 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5027         sigsqtc=-4.0D0*sigcsq*sigtc
5028 c       print *,i,sig,sigtc,sigsqtc
5029 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5030         sigtc=-sigtc/(fac*fac)
5031 C Following variable is sigma(t_c)**(-2)
5032         sigcsq=sigcsq*sigcsq
5033         sig0i=sig0(it)
5034         sig0inv=1.0D0/sig0i**2
5035         delthec=thetai-thet_pred_mean
5036         delthe0=thetai-theta0i
5037         term1=-0.5D0*sigcsq*delthec*delthec
5038         term2=-0.5D0*sig0inv*delthe0*delthe0
5039 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5040 C NaNs in taking the logarithm. We extract the largest exponent which is added
5041 C to the energy (this being the log of the distribution) at the end of energy
5042 C term evaluation for this virtual-bond angle.
5043         if (term1.gt.term2) then
5044           termm=term1
5045           term2=dexp(term2-termm)
5046           term1=1.0d0
5047         else
5048           termm=term2
5049           term1=dexp(term1-termm)
5050           term2=1.0d0
5051         endif
5052 C The ratio between the gamma-independent and gamma-dependent lobes of
5053 C the distribution is a Gaussian function of thet_pred_mean too.
5054         diffak=gthet(2,it)-thet_pred_mean
5055         ratak=diffak/gthet(3,it)**2
5056         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5057 C Let's differentiate it in thet_pred_mean NOW.
5058         aktc=ak*ratak
5059 C Now put together the distribution terms to make complete distribution.
5060         termexp=term1+ak*term2
5061         termpre=sigc+ak*sig0i
5062 C Contribution of the bending energy from this theta is just the -log of
5063 C the sum of the contributions from the two lobes and the pre-exponential
5064 C factor. Simple enough, isn't it?
5065         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5066 C NOW the derivatives!!!
5067 C 6/6/97 Take into account the deformation.
5068         E_theta=(delthec*sigcsq*term1
5069      &       +ak*delthe0*sig0inv*term2)/termexp
5070         E_tc=((sigtc+aktc*sig0i)/termpre
5071      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5072      &       aktc*term2)/termexp)
5073       return
5074       end
5075 c-----------------------------------------------------------------------------
5076       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5077       implicit real*8 (a-h,o-z)
5078       include 'DIMENSIONS'
5079       include 'COMMON.LOCAL'
5080       include 'COMMON.IOUNITS'
5081       common /calcthet/ term1,term2,termm,diffak,ratak,
5082      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5083      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5084       delthec=thetai-thet_pred_mean
5085       delthe0=thetai-theta0i
5086 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5087       t3 = thetai-thet_pred_mean
5088       t6 = t3**2
5089       t9 = term1
5090       t12 = t3*sigcsq
5091       t14 = t12+t6*sigsqtc
5092       t16 = 1.0d0
5093       t21 = thetai-theta0i
5094       t23 = t21**2
5095       t26 = term2
5096       t27 = t21*t26
5097       t32 = termexp
5098       t40 = t32**2
5099       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5100      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5101      & *(-t12*t9-ak*sig0inv*t27)
5102       return
5103       end
5104 #else
5105 C--------------------------------------------------------------------------
5106       subroutine ebend(etheta)
5107 C
5108 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5109 C angles gamma and its derivatives in consecutive thetas and gammas.
5110 C ab initio-derived potentials from
5111 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5112 C
5113       implicit real*8 (a-h,o-z)
5114       include 'DIMENSIONS'
5115       include 'DIMENSIONS.ZSCOPT'
5116       include 'COMMON.LOCAL'
5117       include 'COMMON.GEO'
5118       include 'COMMON.INTERACT'
5119       include 'COMMON.DERIV'
5120       include 'COMMON.VAR'
5121       include 'COMMON.CHAIN'
5122       include 'COMMON.IOUNITS'
5123       include 'COMMON.NAMES'
5124       include 'COMMON.FFIELD'
5125       include 'COMMON.CONTROL'
5126       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5127      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5128      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5129      & sinph1ph2(maxdouble,maxdouble)
5130       logical lprn /.false./, lprn1 /.false./
5131       etheta=0.0D0
5132 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5133       do i=ithet_start,ithet_end
5134         dethetai=0.0d0
5135         dephii=0.0d0
5136         dephii1=0.0d0
5137         theti2=0.5d0*theta(i)
5138         ityp2=ithetyp(itype(i-1))
5139         do k=1,nntheterm
5140           coskt(k)=dcos(k*theti2)
5141           sinkt(k)=dsin(k*theti2)
5142         enddo
5143         if (i.gt.3) then
5144 #ifdef OSF
5145           phii=phi(i)
5146           if (phii.ne.phii) phii=150.0
5147 #else
5148           phii=phi(i)
5149 #endif
5150           ityp1=ithetyp(itype(i-2))
5151           do k=1,nsingle
5152             cosph1(k)=dcos(k*phii)
5153             sinph1(k)=dsin(k*phii)
5154           enddo
5155         else
5156           phii=0.0d0
5157           ityp1=nthetyp+1
5158           do k=1,nsingle
5159             cosph1(k)=0.0d0
5160             sinph1(k)=0.0d0
5161           enddo
5162         endif
5163         if (i.lt.nres) then
5164 #ifdef OSF
5165           phii1=phi(i+1)
5166           if (phii1.ne.phii1) phii1=150.0
5167           phii1=pinorm(phii1)
5168 #else
5169           phii1=phi(i+1)
5170 #endif
5171           ityp3=ithetyp(itype(i))
5172           do k=1,nsingle
5173             cosph2(k)=dcos(k*phii1)
5174             sinph2(k)=dsin(k*phii1)
5175           enddo
5176         else
5177           phii1=0.0d0
5178           ityp3=nthetyp+1
5179           do k=1,nsingle
5180             cosph2(k)=0.0d0
5181             sinph2(k)=0.0d0
5182           enddo
5183         endif
5184 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5185 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5186 c        call flush(iout)
5187         ethetai=aa0thet(ityp1,ityp2,ityp3)
5188         do k=1,ndouble
5189           do l=1,k-1
5190             ccl=cosph1(l)*cosph2(k-l)
5191             ssl=sinph1(l)*sinph2(k-l)
5192             scl=sinph1(l)*cosph2(k-l)
5193             csl=cosph1(l)*sinph2(k-l)
5194             cosph1ph2(l,k)=ccl-ssl
5195             cosph1ph2(k,l)=ccl+ssl
5196             sinph1ph2(l,k)=scl+csl
5197             sinph1ph2(k,l)=scl-csl
5198           enddo
5199         enddo
5200         if (lprn) then
5201         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5202      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5203         write (iout,*) "coskt and sinkt"
5204         do k=1,nntheterm
5205           write (iout,*) k,coskt(k),sinkt(k)
5206         enddo
5207         endif
5208         do k=1,ntheterm
5209           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
5210           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
5211      &      *coskt(k)
5212           if (lprn)
5213      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
5214      &     " ethetai",ethetai
5215         enddo
5216         if (lprn) then
5217         write (iout,*) "cosph and sinph"
5218         do k=1,nsingle
5219           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5220         enddo
5221         write (iout,*) "cosph1ph2 and sinph2ph2"
5222         do k=2,ndouble
5223           do l=1,k-1
5224             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5225      &         sinph1ph2(l,k),sinph1ph2(k,l)
5226           enddo
5227         enddo
5228         write(iout,*) "ethetai",ethetai
5229         endif
5230         do m=1,ntheterm2
5231           do k=1,nsingle
5232             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
5233      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
5234      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
5235      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
5236             ethetai=ethetai+sinkt(m)*aux
5237             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5238             dephii=dephii+k*sinkt(m)*(
5239      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
5240      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
5241             dephii1=dephii1+k*sinkt(m)*(
5242      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
5243      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
5244             if (lprn)
5245      &      write (iout,*) "m",m," k",k," bbthet",
5246      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
5247      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
5248      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
5249      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5250           enddo
5251         enddo
5252         if (lprn)
5253      &  write(iout,*) "ethetai",ethetai
5254         do m=1,ntheterm3
5255           do k=2,ndouble
5256             do l=1,k-1
5257               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5258      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
5259      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5260      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
5261               ethetai=ethetai+sinkt(m)*aux
5262               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5263               dephii=dephii+l*sinkt(m)*(
5264      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
5265      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5266      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5267      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5268               dephii1=dephii1+(k-l)*sinkt(m)*(
5269      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5270      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5271      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5272      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5273               if (lprn) then
5274               write (iout,*) "m",m," k",k," l",l," ffthet",
5275      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5276      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5277      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5278      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5279               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5280      &            cosph1ph2(k,l)*sinkt(m),
5281      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5282               endif
5283             enddo
5284           enddo
5285         enddo
5286 10      continue
5287         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5288      &   i,theta(i)*rad2deg,phii*rad2deg,
5289      &   phii1*rad2deg,ethetai
5290         etheta=etheta+ethetai
5291         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5292         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5293         gloc(nphi+i-2,icg)=wang*dethetai
5294       enddo
5295       return
5296       end
5297 #endif
5298 #ifdef CRYST_SC
5299 c-----------------------------------------------------------------------------
5300       subroutine esc(escloc)
5301 C Calculate the local energy of a side chain and its derivatives in the
5302 C corresponding virtual-bond valence angles THETA and the spherical angles
5303 C ALPHA and OMEGA.
5304       implicit real*8 (a-h,o-z)
5305       include 'DIMENSIONS'
5306       include 'DIMENSIONS.ZSCOPT'
5307       include 'COMMON.GEO'
5308       include 'COMMON.LOCAL'
5309       include 'COMMON.VAR'
5310       include 'COMMON.INTERACT'
5311       include 'COMMON.DERIV'
5312       include 'COMMON.CHAIN'
5313       include 'COMMON.IOUNITS'
5314       include 'COMMON.NAMES'
5315       include 'COMMON.FFIELD'
5316       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5317      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5318       common /sccalc/ time11,time12,time112,theti,it,nlobit
5319       delta=0.02d0*pi
5320       escloc=0.0D0
5321 c     write (iout,'(a)') 'ESC'
5322       do i=loc_start,loc_end
5323         it=itype(i)
5324         if (it.eq.10) goto 1
5325         nlobit=nlob(it)
5326 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5327 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5328         theti=theta(i+1)-pipol
5329         x(1)=dtan(theti)
5330         x(2)=alph(i)
5331         x(3)=omeg(i)
5332 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5333
5334         if (x(2).gt.pi-delta) then
5335           xtemp(1)=x(1)
5336           xtemp(2)=pi-delta
5337           xtemp(3)=x(3)
5338           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5339           xtemp(2)=pi
5340           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5341           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5342      &        escloci,dersc(2))
5343           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5344      &        ddersc0(1),dersc(1))
5345           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5346      &        ddersc0(3),dersc(3))
5347           xtemp(2)=pi-delta
5348           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5349           xtemp(2)=pi
5350           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5351           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5352      &            dersc0(2),esclocbi,dersc02)
5353           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5354      &            dersc12,dersc01)
5355           call splinthet(x(2),0.5d0*delta,ss,ssd)
5356           dersc0(1)=dersc01
5357           dersc0(2)=dersc02
5358           dersc0(3)=0.0d0
5359           do k=1,3
5360             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5361           enddo
5362           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5363 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5364 c    &             esclocbi,ss,ssd
5365           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5366 c         escloci=esclocbi
5367 c         write (iout,*) escloci
5368         else if (x(2).lt.delta) then
5369           xtemp(1)=x(1)
5370           xtemp(2)=delta
5371           xtemp(3)=x(3)
5372           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5373           xtemp(2)=0.0d0
5374           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5375           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5376      &        escloci,dersc(2))
5377           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5378      &        ddersc0(1),dersc(1))
5379           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5380      &        ddersc0(3),dersc(3))
5381           xtemp(2)=delta
5382           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5383           xtemp(2)=0.0d0
5384           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5385           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5386      &            dersc0(2),esclocbi,dersc02)
5387           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5388      &            dersc12,dersc01)
5389           dersc0(1)=dersc01
5390           dersc0(2)=dersc02
5391           dersc0(3)=0.0d0
5392           call splinthet(x(2),0.5d0*delta,ss,ssd)
5393           do k=1,3
5394             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5395           enddo
5396           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5397 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5398 c    &             esclocbi,ss,ssd
5399           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5400 c         write (iout,*) escloci
5401         else
5402           call enesc(x,escloci,dersc,ddummy,.false.)
5403         endif
5404
5405         escloc=escloc+escloci
5406 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5407
5408         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5409      &   wscloc*dersc(1)
5410         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5411         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5412     1   continue
5413       enddo
5414       return
5415       end
5416 C---------------------------------------------------------------------------
5417       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5418       implicit real*8 (a-h,o-z)
5419       include 'DIMENSIONS'
5420       include 'COMMON.GEO'
5421       include 'COMMON.LOCAL'
5422       include 'COMMON.IOUNITS'
5423       common /sccalc/ time11,time12,time112,theti,it,nlobit
5424       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5425       double precision contr(maxlob,-1:1)
5426       logical mixed
5427 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5428         escloc_i=0.0D0
5429         do j=1,3
5430           dersc(j)=0.0D0
5431           if (mixed) ddersc(j)=0.0d0
5432         enddo
5433         x3=x(3)
5434
5435 C Because of periodicity of the dependence of the SC energy in omega we have
5436 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5437 C To avoid underflows, first compute & store the exponents.
5438
5439         do iii=-1,1
5440
5441           x(3)=x3+iii*dwapi
5442
5443           do j=1,nlobit
5444             do k=1,3
5445               z(k)=x(k)-censc(k,j,it)
5446             enddo
5447             do k=1,3
5448               Axk=0.0D0
5449               do l=1,3
5450                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5451               enddo
5452               Ax(k,j,iii)=Axk
5453             enddo
5454             expfac=0.0D0
5455             do k=1,3
5456               expfac=expfac+Ax(k,j,iii)*z(k)
5457             enddo
5458             contr(j,iii)=expfac
5459           enddo ! j
5460
5461         enddo ! iii
5462
5463         x(3)=x3
5464 C As in the case of ebend, we want to avoid underflows in exponentiation and
5465 C subsequent NaNs and INFs in energy calculation.
5466 C Find the largest exponent
5467         emin=contr(1,-1)
5468         do iii=-1,1
5469           do j=1,nlobit
5470             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5471           enddo
5472         enddo
5473         emin=0.5D0*emin
5474 cd      print *,'it=',it,' emin=',emin
5475
5476 C Compute the contribution to SC energy and derivatives
5477         do iii=-1,1
5478
5479           do j=1,nlobit
5480             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5481 cd          print *,'j=',j,' expfac=',expfac
5482             escloc_i=escloc_i+expfac
5483             do k=1,3
5484               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5485             enddo
5486             if (mixed) then
5487               do k=1,3,2
5488                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5489      &            +gaussc(k,2,j,it))*expfac
5490               enddo
5491             endif
5492           enddo
5493
5494         enddo ! iii
5495
5496         dersc(1)=dersc(1)/cos(theti)**2
5497         ddersc(1)=ddersc(1)/cos(theti)**2
5498         ddersc(3)=ddersc(3)
5499
5500         escloci=-(dlog(escloc_i)-emin)
5501         do j=1,3
5502           dersc(j)=dersc(j)/escloc_i
5503         enddo
5504         if (mixed) then
5505           do j=1,3,2
5506             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5507           enddo
5508         endif
5509       return
5510       end
5511 C------------------------------------------------------------------------------
5512       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5513       implicit real*8 (a-h,o-z)
5514       include 'DIMENSIONS'
5515       include 'COMMON.GEO'
5516       include 'COMMON.LOCAL'
5517       include 'COMMON.IOUNITS'
5518       common /sccalc/ time11,time12,time112,theti,it,nlobit
5519       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5520       double precision contr(maxlob)
5521       logical mixed
5522
5523       escloc_i=0.0D0
5524
5525       do j=1,3
5526         dersc(j)=0.0D0
5527       enddo
5528
5529       do j=1,nlobit
5530         do k=1,2
5531           z(k)=x(k)-censc(k,j,it)
5532         enddo
5533         z(3)=dwapi
5534         do k=1,3
5535           Axk=0.0D0
5536           do l=1,3
5537             Axk=Axk+gaussc(l,k,j,it)*z(l)
5538           enddo
5539           Ax(k,j)=Axk
5540         enddo
5541         expfac=0.0D0
5542         do k=1,3
5543           expfac=expfac+Ax(k,j)*z(k)
5544         enddo
5545         contr(j)=expfac
5546       enddo ! j
5547
5548 C As in the case of ebend, we want to avoid underflows in exponentiation and
5549 C subsequent NaNs and INFs in energy calculation.
5550 C Find the largest exponent
5551       emin=contr(1)
5552       do j=1,nlobit
5553         if (emin.gt.contr(j)) emin=contr(j)
5554       enddo
5555       emin=0.5D0*emin
5556
5557 C Compute the contribution to SC energy and derivatives
5558
5559       dersc12=0.0d0
5560       do j=1,nlobit
5561         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5562         escloc_i=escloc_i+expfac
5563         do k=1,2
5564           dersc(k)=dersc(k)+Ax(k,j)*expfac
5565         enddo
5566         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5567      &            +gaussc(1,2,j,it))*expfac
5568         dersc(3)=0.0d0
5569       enddo
5570
5571       dersc(1)=dersc(1)/cos(theti)**2
5572       dersc12=dersc12/cos(theti)**2
5573       escloci=-(dlog(escloc_i)-emin)
5574       do j=1,2
5575         dersc(j)=dersc(j)/escloc_i
5576       enddo
5577       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5578       return
5579       end
5580 #else
5581 c----------------------------------------------------------------------------------
5582       subroutine esc(escloc)
5583 C Calculate the local energy of a side chain and its derivatives in the
5584 C corresponding virtual-bond valence angles THETA and the spherical angles
5585 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5586 C added by Urszula Kozlowska. 07/11/2007
5587 C
5588       implicit real*8 (a-h,o-z)
5589       include 'DIMENSIONS'
5590       include 'DIMENSIONS.ZSCOPT'
5591       include 'COMMON.GEO'
5592       include 'COMMON.LOCAL'
5593       include 'COMMON.VAR'
5594       include 'COMMON.SCROT'
5595       include 'COMMON.INTERACT'
5596       include 'COMMON.DERIV'
5597       include 'COMMON.CHAIN'
5598       include 'COMMON.IOUNITS'
5599       include 'COMMON.NAMES'
5600       include 'COMMON.FFIELD'
5601       include 'COMMON.CONTROL'
5602       include 'COMMON.VECTORS'
5603       double precision x_prime(3),y_prime(3),z_prime(3)
5604      &    , sumene,dsc_i,dp2_i,x(65),
5605      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5606      &    de_dxx,de_dyy,de_dzz,de_dt
5607       double precision s1_t,s1_6_t,s2_t,s2_6_t
5608       double precision
5609      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5610      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5611      & dt_dCi(3),dt_dCi1(3)
5612       common /sccalc/ time11,time12,time112,theti,it,nlobit
5613       delta=0.02d0*pi
5614       escloc=0.0D0
5615       do i=loc_start,loc_end
5616         costtab(i+1) =dcos(theta(i+1))
5617         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5618         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5619         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5620         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5621         cosfac=dsqrt(cosfac2)
5622         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5623         sinfac=dsqrt(sinfac2)
5624         it=itype(i)
5625         if (it.eq.10) goto 1
5626 c
5627 C  Compute the axes of tghe local cartesian coordinates system; store in
5628 c   x_prime, y_prime and z_prime
5629 c
5630         do j=1,3
5631           x_prime(j) = 0.00
5632           y_prime(j) = 0.00
5633           z_prime(j) = 0.00
5634         enddo
5635 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5636 C     &   dc_norm(3,i+nres)
5637         do j = 1,3
5638           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5639           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5640         enddo
5641         do j = 1,3
5642           z_prime(j) = -uz(j,i-1)
5643         enddo
5644 c       write (2,*) "i",i
5645 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5646 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5647 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5648 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5649 c      & " xy",scalar(x_prime(1),y_prime(1)),
5650 c      & " xz",scalar(x_prime(1),z_prime(1)),
5651 c      & " yy",scalar(y_prime(1),y_prime(1)),
5652 c      & " yz",scalar(y_prime(1),z_prime(1)),
5653 c      & " zz",scalar(z_prime(1),z_prime(1))
5654 c
5655 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5656 C to local coordinate system. Store in xx, yy, zz.
5657 c
5658         xx=0.0d0
5659         yy=0.0d0
5660         zz=0.0d0
5661         do j = 1,3
5662           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5663           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5664           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5665         enddo
5666
5667         xxtab(i)=xx
5668         yytab(i)=yy
5669         zztab(i)=zz
5670 C
5671 C Compute the energy of the ith side cbain
5672 C
5673 c        write (2,*) "xx",xx," yy",yy," zz",zz
5674         it=itype(i)
5675         do j = 1,65
5676           x(j) = sc_parmin(j,it)
5677         enddo
5678 #ifdef CHECK_COORD
5679 Cc diagnostics - remove later
5680         xx1 = dcos(alph(2))
5681         yy1 = dsin(alph(2))*dcos(omeg(2))
5682         zz1 = -dsin(alph(2))*dsin(omeg(2))
5683         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5684      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5685      &    xx1,yy1,zz1
5686 C,"  --- ", xx_w,yy_w,zz_w
5687 c end diagnostics
5688 #endif
5689         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5690      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5691      &   + x(10)*yy*zz
5692         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5693      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5694      & + x(20)*yy*zz
5695         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5696      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5697      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5698      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5699      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5700      &  +x(40)*xx*yy*zz
5701         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5702      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5703      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5704      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5705      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5706      &  +x(60)*xx*yy*zz
5707         dsc_i   = 0.743d0+x(61)
5708         dp2_i   = 1.9d0+x(62)
5709         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5710      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5711         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5712      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5713         s1=(1+x(63))/(0.1d0 + dscp1)
5714         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5715         s2=(1+x(65))/(0.1d0 + dscp2)
5716         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5717         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5718      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5719 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5720 c     &   sumene4,
5721 c     &   dscp1,dscp2,sumene
5722 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5723         escloc = escloc + sumene
5724 c        write (2,*) "escloc",escloc
5725         if (.not. calc_grad) goto 1
5726 #ifdef DEBUG
5727 C
5728 C This section to check the numerical derivatives of the energy of ith side
5729 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5730 C #define DEBUG in the code to turn it on.
5731 C
5732         write (2,*) "sumene               =",sumene
5733         aincr=1.0d-7
5734         xxsave=xx
5735         xx=xx+aincr
5736         write (2,*) xx,yy,zz
5737         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5738         de_dxx_num=(sumenep-sumene)/aincr
5739         xx=xxsave
5740         write (2,*) "xx+ sumene from enesc=",sumenep
5741         yysave=yy
5742         yy=yy+aincr
5743         write (2,*) xx,yy,zz
5744         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5745         de_dyy_num=(sumenep-sumene)/aincr
5746         yy=yysave
5747         write (2,*) "yy+ sumene from enesc=",sumenep
5748         zzsave=zz
5749         zz=zz+aincr
5750         write (2,*) xx,yy,zz
5751         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5752         de_dzz_num=(sumenep-sumene)/aincr
5753         zz=zzsave
5754         write (2,*) "zz+ sumene from enesc=",sumenep
5755         costsave=cost2tab(i+1)
5756         sintsave=sint2tab(i+1)
5757         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5758         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5759         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5760         de_dt_num=(sumenep-sumene)/aincr
5761         write (2,*) " t+ sumene from enesc=",sumenep
5762         cost2tab(i+1)=costsave
5763         sint2tab(i+1)=sintsave
5764 C End of diagnostics section.
5765 #endif
5766 C
5767 C Compute the gradient of esc
5768 C
5769         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5770         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5771         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5772         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5773         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5774         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5775         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5776         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5777         pom1=(sumene3*sint2tab(i+1)+sumene1)
5778      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5779         pom2=(sumene4*cost2tab(i+1)+sumene2)
5780      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5781         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5782         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5783      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5784      &  +x(40)*yy*zz
5785         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5786         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5787      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5788      &  +x(60)*yy*zz
5789         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5790      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5791      &        +(pom1+pom2)*pom_dx
5792 #ifdef DEBUG
5793         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5794 #endif
5795 C
5796         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5797         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5798      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5799      &  +x(40)*xx*zz
5800         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5801         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5802      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5803      &  +x(59)*zz**2 +x(60)*xx*zz
5804         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5805      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5806      &        +(pom1-pom2)*pom_dy
5807 #ifdef DEBUG
5808         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5809 #endif
5810 C
5811         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5812      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5813      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5814      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5815      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5816      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5817      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5818      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5819 #ifdef DEBUG
5820         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5821 #endif
5822 C
5823         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5824      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5825      &  +pom1*pom_dt1+pom2*pom_dt2
5826 #ifdef DEBUG
5827         write(2,*), "de_dt = ", de_dt,de_dt_num
5828 #endif
5829 c
5830 C
5831        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5832        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5833        cosfac2xx=cosfac2*xx
5834        sinfac2yy=sinfac2*yy
5835        do k = 1,3
5836          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5837      &      vbld_inv(i+1)
5838          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5839      &      vbld_inv(i)
5840          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5841          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5842 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5843 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5844 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5845 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5846          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5847          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5848          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5849          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5850          dZZ_Ci1(k)=0.0d0
5851          dZZ_Ci(k)=0.0d0
5852          do j=1,3
5853            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5854            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5855          enddo
5856
5857          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5858          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5859          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5860 c
5861          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5862          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5863        enddo
5864
5865        do k=1,3
5866          dXX_Ctab(k,i)=dXX_Ci(k)
5867          dXX_C1tab(k,i)=dXX_Ci1(k)
5868          dYY_Ctab(k,i)=dYY_Ci(k)
5869          dYY_C1tab(k,i)=dYY_Ci1(k)
5870          dZZ_Ctab(k,i)=dZZ_Ci(k)
5871          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5872          dXX_XYZtab(k,i)=dXX_XYZ(k)
5873          dYY_XYZtab(k,i)=dYY_XYZ(k)
5874          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5875        enddo
5876
5877        do k = 1,3
5878 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5879 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5880 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5881 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5882 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5883 c     &    dt_dci(k)
5884 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5885 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5886          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5887      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5888          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5889      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5890          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5891      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5892        enddo
5893 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5894 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5895
5896 C to check gradient call subroutine check_grad
5897
5898     1 continue
5899       enddo
5900       return
5901       end
5902 #endif
5903 c------------------------------------------------------------------------------
5904       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5905 C
5906 C This procedure calculates two-body contact function g(rij) and its derivative:
5907 C
5908 C           eps0ij                                     !       x < -1
5909 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5910 C            0                                         !       x > 1
5911 C
5912 C where x=(rij-r0ij)/delta
5913 C
5914 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5915 C
5916       implicit none
5917       double precision rij,r0ij,eps0ij,fcont,fprimcont
5918       double precision x,x2,x4,delta
5919 c     delta=0.02D0*r0ij
5920 c      delta=0.2D0*r0ij
5921       x=(rij-r0ij)/delta
5922       if (x.lt.-1.0D0) then
5923         fcont=eps0ij
5924         fprimcont=0.0D0
5925       else if (x.le.1.0D0) then
5926         x2=x*x
5927         x4=x2*x2
5928         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5929         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5930       else
5931         fcont=0.0D0
5932         fprimcont=0.0D0
5933       endif
5934       return
5935       end
5936 c------------------------------------------------------------------------------
5937       subroutine splinthet(theti,delta,ss,ssder)
5938       implicit real*8 (a-h,o-z)
5939       include 'DIMENSIONS'
5940       include 'DIMENSIONS.ZSCOPT'
5941       include 'COMMON.VAR'
5942       include 'COMMON.GEO'
5943       thetup=pi-delta
5944       thetlow=delta
5945       if (theti.gt.pipol) then
5946         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5947       else
5948         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5949         ssder=-ssder
5950       endif
5951       return
5952       end
5953 c------------------------------------------------------------------------------
5954       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5955       implicit none
5956       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5957       double precision ksi,ksi2,ksi3,a1,a2,a3
5958       a1=fprim0*delta/(f1-f0)
5959       a2=3.0d0-2.0d0*a1
5960       a3=a1-2.0d0
5961       ksi=(x-x0)/delta
5962       ksi2=ksi*ksi
5963       ksi3=ksi2*ksi
5964       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5965       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5966       return
5967       end
5968 c------------------------------------------------------------------------------
5969       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5970       implicit none
5971       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5972       double precision ksi,ksi2,ksi3,a1,a2,a3
5973       ksi=(x-x0)/delta
5974       ksi2=ksi*ksi
5975       ksi3=ksi2*ksi
5976       a1=fprim0x*delta
5977       a2=3*(f1x-f0x)-2*fprim0x*delta
5978       a3=fprim0x*delta-2*(f1x-f0x)
5979       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5980       return
5981       end
5982 C-----------------------------------------------------------------------------
5983 #ifdef CRYST_TOR
5984 C-----------------------------------------------------------------------------
5985       subroutine etor(etors,edihcnstr,fact)
5986       implicit real*8 (a-h,o-z)
5987       include 'DIMENSIONS'
5988       include 'DIMENSIONS.ZSCOPT'
5989       include 'COMMON.VAR'
5990       include 'COMMON.GEO'
5991       include 'COMMON.LOCAL'
5992       include 'COMMON.TORSION'
5993       include 'COMMON.INTERACT'
5994       include 'COMMON.DERIV'
5995       include 'COMMON.CHAIN'
5996       include 'COMMON.NAMES'
5997       include 'COMMON.IOUNITS'
5998       include 'COMMON.FFIELD'
5999       include 'COMMON.TORCNSTR'
6000       logical lprn
6001 C Set lprn=.true. for debugging
6002       lprn=.false.
6003 c      lprn=.true.
6004       etors=0.0D0
6005       do i=iphi_start,iphi_end
6006         itori=itortyp(itype(i-2))
6007         itori1=itortyp(itype(i-1))
6008         phii=phi(i)
6009         gloci=0.0D0
6010 C Proline-Proline pair is a special case...
6011         if (itori.eq.3 .and. itori1.eq.3) then
6012           if (phii.gt.-dwapi3) then
6013             cosphi=dcos(3*phii)
6014             fac=1.0D0/(1.0D0-cosphi)
6015             etorsi=v1(1,3,3)*fac
6016             etorsi=etorsi+etorsi
6017             etors=etors+etorsi-v1(1,3,3)
6018             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6019           endif
6020           do j=1,3
6021             v1ij=v1(j+1,itori,itori1)
6022             v2ij=v2(j+1,itori,itori1)
6023             cosphi=dcos(j*phii)
6024             sinphi=dsin(j*phii)
6025             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6026             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6027           enddo
6028         else
6029           do j=1,nterm_old
6030             v1ij=v1(j,itori,itori1)
6031             v2ij=v2(j,itori,itori1)
6032             cosphi=dcos(j*phii)
6033             sinphi=dsin(j*phii)
6034             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6035             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6036           enddo
6037         endif
6038         if (lprn)
6039      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6040      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6041      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6042         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6043 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6044       enddo
6045 ! 6/20/98 - dihedral angle constraints
6046       edihcnstr=0.0d0
6047       do i=1,ndih_constr
6048         itori=idih_constr(i)
6049         phii=phi(itori)
6050         difi=phii-phi0(i)
6051         if (difi.gt.drange(i)) then
6052           difi=difi-drange(i)
6053           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6054           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6055         else if (difi.lt.-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         endif
6060 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6061 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6062       enddo
6063 !      write (iout,*) 'edihcnstr',edihcnstr
6064       return
6065       end
6066 c------------------------------------------------------------------------------
6067 #else
6068       subroutine etor(etors,edihcnstr,fact)
6069       implicit real*8 (a-h,o-z)
6070       include 'DIMENSIONS'
6071       include 'DIMENSIONS.ZSCOPT'
6072       include 'COMMON.VAR'
6073       include 'COMMON.GEO'
6074       include 'COMMON.LOCAL'
6075       include 'COMMON.TORSION'
6076       include 'COMMON.INTERACT'
6077       include 'COMMON.DERIV'
6078       include 'COMMON.CHAIN'
6079       include 'COMMON.NAMES'
6080       include 'COMMON.IOUNITS'
6081       include 'COMMON.FFIELD'
6082       include 'COMMON.TORCNSTR'
6083       logical lprn
6084 C Set lprn=.true. for debugging
6085       lprn=.false.
6086 c      lprn=.true.
6087       etors=0.0D0
6088       do i=iphi_start,iphi_end
6089         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6090         itori=itortyp(itype(i-2))
6091         itori1=itortyp(itype(i-1))
6092         phii=phi(i)
6093         gloci=0.0D0
6094 C Regular cosine and sine terms
6095         do j=1,nterm(itori,itori1)
6096           v1ij=v1(j,itori,itori1)
6097           v2ij=v2(j,itori,itori1)
6098           cosphi=dcos(j*phii)
6099           sinphi=dsin(j*phii)
6100           etors=etors+v1ij*cosphi+v2ij*sinphi
6101           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6102         enddo
6103 C Lorentz terms
6104 C                         v1
6105 C  E = SUM ----------------------------------- - v1
6106 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6107 C
6108         cosphi=dcos(0.5d0*phii)
6109         sinphi=dsin(0.5d0*phii)
6110         do j=1,nlor(itori,itori1)
6111           vl1ij=vlor1(j,itori,itori1)
6112           vl2ij=vlor2(j,itori,itori1)
6113           vl3ij=vlor3(j,itori,itori1)
6114           pom=vl2ij*cosphi+vl3ij*sinphi
6115           pom1=1.0d0/(pom*pom+1.0d0)
6116           etors=etors+vl1ij*pom1
6117           pom=-pom*pom1*pom1
6118           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6119         enddo
6120 C Subtract the constant term
6121         etors=etors-v0(itori,itori1)
6122         if (lprn)
6123      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6124      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6125      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6126         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6127 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6128  1215   continue
6129       enddo
6130 ! 6/20/98 - dihedral angle constraints
6131       edihcnstr=0.0d0
6132       do i=1,ndih_constr
6133         itori=idih_constr(i)
6134         phii=phi(itori)
6135         difi=pinorm(phii-phi0(i))
6136         edihi=0.0d0
6137         if (difi.gt.drange(i)) then
6138           difi=difi-drange(i)
6139           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6140           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6141           edihi=0.25d0*ftors*difi**4
6142         else if (difi.lt.-drange(i)) then
6143           difi=difi+drange(i)
6144           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6145           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6146           edihi=0.25d0*ftors*difi**4
6147         else
6148           difi=0.0d0
6149         endif
6150 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
6151 c     &    drange(i),edihi
6152 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6153 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6154       enddo
6155 !      write (iout,*) 'edihcnstr',edihcnstr
6156       return
6157       end
6158 c----------------------------------------------------------------------------
6159       subroutine etor_d(etors_d,fact2)
6160 C 6/23/01 Compute double torsional energy
6161       implicit real*8 (a-h,o-z)
6162       include 'DIMENSIONS'
6163       include 'DIMENSIONS.ZSCOPT'
6164       include 'COMMON.VAR'
6165       include 'COMMON.GEO'
6166       include 'COMMON.LOCAL'
6167       include 'COMMON.TORSION'
6168       include 'COMMON.INTERACT'
6169       include 'COMMON.DERIV'
6170       include 'COMMON.CHAIN'
6171       include 'COMMON.NAMES'
6172       include 'COMMON.IOUNITS'
6173       include 'COMMON.FFIELD'
6174       include 'COMMON.TORCNSTR'
6175       logical lprn
6176 C Set lprn=.true. for debugging
6177       lprn=.false.
6178 c     lprn=.true.
6179       etors_d=0.0D0
6180       do i=iphi_start,iphi_end-1
6181         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6182      &     goto 1215
6183         itori=itortyp(itype(i-2))
6184         itori1=itortyp(itype(i-1))
6185         itori2=itortyp(itype(i))
6186         phii=phi(i)
6187         phii1=phi(i+1)
6188         gloci1=0.0D0
6189         gloci2=0.0D0
6190 C Regular cosine and sine terms
6191         do j=1,ntermd_1(itori,itori1,itori2)
6192           v1cij=v1c(1,j,itori,itori1,itori2)
6193           v1sij=v1s(1,j,itori,itori1,itori2)
6194           v2cij=v1c(2,j,itori,itori1,itori2)
6195           v2sij=v1s(2,j,itori,itori1,itori2)
6196           cosphi1=dcos(j*phii)
6197           sinphi1=dsin(j*phii)
6198           cosphi2=dcos(j*phii1)
6199           sinphi2=dsin(j*phii1)
6200           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6201      &     v2cij*cosphi2+v2sij*sinphi2
6202           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6203           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6204         enddo
6205         do k=2,ntermd_2(itori,itori1,itori2)
6206           do l=1,k-1
6207             v1cdij = v2c(k,l,itori,itori1,itori2)
6208             v2cdij = v2c(l,k,itori,itori1,itori2)
6209             v1sdij = v2s(k,l,itori,itori1,itori2)
6210             v2sdij = v2s(l,k,itori,itori1,itori2)
6211             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6212             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6213             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6214             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6215             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6216      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6217             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6218      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6219             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6220      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6221           enddo
6222         enddo
6223         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6224         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6225  1215   continue
6226       enddo
6227       return
6228       end
6229 #endif
6230 c------------------------------------------------------------------------------
6231       subroutine eback_sc_corr(esccor)
6232 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6233 c        conformational states; temporarily implemented as differences
6234 c        between UNRES torsional potentials (dependent on three types of
6235 c        residues) and the torsional potentials dependent on all 20 types
6236 c        of residues computed from AM1 energy surfaces of terminally-blocked
6237 c        amino-acid residues.
6238       implicit real*8 (a-h,o-z)
6239       include 'DIMENSIONS'
6240       include 'DIMENSIONS.ZSCOPT'
6241       include 'COMMON.VAR'
6242       include 'COMMON.GEO'
6243       include 'COMMON.LOCAL'
6244       include 'COMMON.TORSION'
6245       include 'COMMON.SCCOR'
6246       include 'COMMON.INTERACT'
6247       include 'COMMON.DERIV'
6248       include 'COMMON.CHAIN'
6249       include 'COMMON.NAMES'
6250       include 'COMMON.IOUNITS'
6251       include 'COMMON.FFIELD'
6252       include 'COMMON.CONTROL'
6253       logical lprn
6254 C Set lprn=.true. for debugging
6255       lprn=.false.
6256 c      lprn=.true.
6257 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
6258       esccor=0.0D0
6259       do i=itau_start,itau_end
6260         esccor_ii=0.0D0
6261         isccori=isccortyp(itype(i-2))
6262         isccori1=isccortyp(itype(i-1))
6263         phii=phi(i)
6264 cccc  Added 9 May 2012
6265 cc Tauangle is torsional engle depending on the value of first digit
6266 c(see comment below)
6267 cc Omicron is flat angle depending on the value of first digit
6268 c(see comment below)
6269
6270
6271         do intertyp=1,3 !intertyp
6272 cc Added 09 May 2012 (Adasko)
6273 cc  Intertyp means interaction type of backbone mainchain correlation:
6274 c   1 = SC...Ca...Ca...Ca
6275 c   2 = Ca...Ca...Ca...SC
6276 c   3 = SC...Ca...Ca...SCi
6277         gloci=0.0D0
6278         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6279      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6280      &      (itype(i-1).eq.21)))
6281      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6282      &     .or.(itype(i-2).eq.21)))
6283      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6284      &      (itype(i-1).eq.21)))) cycle
6285         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6286         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6287      & cycle
6288         do j=1,nterm_sccor(isccori,isccori1)
6289           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6290           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6291           cosphi=dcos(j*tauangle(intertyp,i))
6292           sinphi=dsin(j*tauangle(intertyp,i))
6293           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6294           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6295         enddo
6296         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6297 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6298 c     &gloc_sc(intertyp,i-3,icg)
6299         if (lprn)
6300      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6301      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6302      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6303      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6304         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6305        enddo !intertyp
6306       enddo
6307 c        do i=1,nres
6308 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6309 c        enddo
6310       return
6311       end
6312 c------------------------------------------------------------------------------
6313       subroutine multibody(ecorr)
6314 C This subroutine calculates multi-body contributions to energy following
6315 C the idea of Skolnick et al. If side chains I and J make a contact and
6316 C at the same time side chains I+1 and J+1 make a contact, an extra
6317 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6318       implicit real*8 (a-h,o-z)
6319       include 'DIMENSIONS'
6320       include 'COMMON.IOUNITS'
6321       include 'COMMON.DERIV'
6322       include 'COMMON.INTERACT'
6323       include 'COMMON.CONTACTS'
6324       double precision gx(3),gx1(3)
6325       logical lprn
6326
6327 C Set lprn=.true. for debugging
6328       lprn=.false.
6329
6330       if (lprn) then
6331         write (iout,'(a)') 'Contact function values:'
6332         do i=nnt,nct-2
6333           write (iout,'(i2,20(1x,i2,f10.5))')
6334      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6335         enddo
6336       endif
6337       ecorr=0.0D0
6338       do i=nnt,nct
6339         do j=1,3
6340           gradcorr(j,i)=0.0D0
6341           gradxorr(j,i)=0.0D0
6342         enddo
6343       enddo
6344       do i=nnt,nct-2
6345
6346         DO ISHIFT = 3,4
6347
6348         i1=i+ishift
6349         num_conti=num_cont(i)
6350         num_conti1=num_cont(i1)
6351         do jj=1,num_conti
6352           j=jcont(jj,i)
6353           do kk=1,num_conti1
6354             j1=jcont(kk,i1)
6355             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6356 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6357 cd   &                   ' ishift=',ishift
6358 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6359 C The system gains extra energy.
6360               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6361             endif   ! j1==j+-ishift
6362           enddo     ! kk
6363         enddo       ! jj
6364
6365         ENDDO ! ISHIFT
6366
6367       enddo         ! i
6368       return
6369       end
6370 c------------------------------------------------------------------------------
6371       double precision function esccorr(i,j,k,l,jj,kk)
6372       implicit real*8 (a-h,o-z)
6373       include 'DIMENSIONS'
6374       include 'COMMON.IOUNITS'
6375       include 'COMMON.DERIV'
6376       include 'COMMON.INTERACT'
6377       include 'COMMON.CONTACTS'
6378       double precision gx(3),gx1(3)
6379       logical lprn
6380       lprn=.false.
6381       eij=facont(jj,i)
6382       ekl=facont(kk,k)
6383 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6384 C Calculate the multi-body contribution to energy.
6385 C Calculate multi-body contributions to the gradient.
6386 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6387 cd   & k,l,(gacont(m,kk,k),m=1,3)
6388       do m=1,3
6389         gx(m) =ekl*gacont(m,jj,i)
6390         gx1(m)=eij*gacont(m,kk,k)
6391         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6392         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6393         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6394         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6395       enddo
6396       do m=i,j-1
6397         do ll=1,3
6398           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6399         enddo
6400       enddo
6401       do m=k,l-1
6402         do ll=1,3
6403           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6404         enddo
6405       enddo
6406       esccorr=-eij*ekl
6407       return
6408       end
6409 c------------------------------------------------------------------------------
6410 #ifdef MPL
6411       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
6412       implicit real*8 (a-h,o-z)
6413       include 'DIMENSIONS'
6414       integer dimen1,dimen2,atom,indx
6415       double precision buffer(dimen1,dimen2)
6416       double precision zapas
6417       common /contacts_hb/ zapas(3,20,maxres,7),
6418      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6419      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6420       num_kont=num_cont_hb(atom)
6421       do i=1,num_kont
6422         do k=1,7
6423           do j=1,3
6424             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
6425           enddo ! j
6426         enddo ! k
6427         buffer(i,indx+22)=facont_hb(i,atom)
6428         buffer(i,indx+23)=ees0p(i,atom)
6429         buffer(i,indx+24)=ees0m(i,atom)
6430         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
6431       enddo ! i
6432       buffer(1,indx+26)=dfloat(num_kont)
6433       return
6434       end
6435 c------------------------------------------------------------------------------
6436       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
6437       implicit real*8 (a-h,o-z)
6438       include 'DIMENSIONS'
6439       integer dimen1,dimen2,atom,indx
6440       double precision buffer(dimen1,dimen2)
6441       double precision zapas
6442       common /contacts_hb/ zapas(3,20,maxres,7),
6443      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6444      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6445       num_kont=buffer(1,indx+26)
6446       num_kont_old=num_cont_hb(atom)
6447       num_cont_hb(atom)=num_kont+num_kont_old
6448       do i=1,num_kont
6449         ii=i+num_kont_old
6450         do k=1,7
6451           do j=1,3
6452             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
6453           enddo ! j
6454         enddo ! k
6455         facont_hb(ii,atom)=buffer(i,indx+22)
6456         ees0p(ii,atom)=buffer(i,indx+23)
6457         ees0m(ii,atom)=buffer(i,indx+24)
6458         jcont_hb(ii,atom)=buffer(i,indx+25)
6459       enddo ! i
6460       return
6461       end
6462 c------------------------------------------------------------------------------
6463 #endif
6464       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6465 C This subroutine calculates multi-body contributions to hydrogen-bonding
6466       implicit real*8 (a-h,o-z)
6467       include 'DIMENSIONS'
6468       include 'DIMENSIONS.ZSCOPT'
6469       include 'COMMON.IOUNITS'
6470 #ifdef MPL
6471       include 'COMMON.INFO'
6472 #endif
6473       include 'COMMON.FFIELD'
6474       include 'COMMON.DERIV'
6475       include 'COMMON.INTERACT'
6476       include 'COMMON.CONTACTS'
6477 #ifdef MPL
6478       parameter (max_cont=maxconts)
6479       parameter (max_dim=2*(8*3+2))
6480       parameter (msglen1=max_cont*max_dim*4)
6481       parameter (msglen2=2*msglen1)
6482       integer source,CorrelType,CorrelID,Error
6483       double precision buffer(max_cont,max_dim)
6484 #endif
6485       double precision gx(3),gx1(3)
6486       logical lprn,ldone
6487
6488 C Set lprn=.true. for debugging
6489       lprn=.false.
6490 #ifdef MPL
6491       n_corr=0
6492       n_corr1=0
6493       if (fgProcs.le.1) goto 30
6494       if (lprn) then
6495         write (iout,'(a)') 'Contact function values:'
6496         do i=nnt,nct-2
6497           write (iout,'(2i3,50(1x,i2,f5.2))')
6498      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6499      &    j=1,num_cont_hb(i))
6500         enddo
6501       endif
6502 C Caution! Following code assumes that electrostatic interactions concerning
6503 C a given atom are split among at most two processors!
6504       CorrelType=477
6505       CorrelID=MyID+1
6506       ldone=.false.
6507       do i=1,max_cont
6508         do j=1,max_dim
6509           buffer(i,j)=0.0D0
6510         enddo
6511       enddo
6512       mm=mod(MyRank,2)
6513 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6514       if (mm) 20,20,10
6515    10 continue
6516 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6517       if (MyRank.gt.0) then
6518 C Send correlation contributions to the preceding processor
6519         msglen=msglen1
6520         nn=num_cont_hb(iatel_s)
6521         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6522 cd      write (iout,*) 'The BUFFER array:'
6523 cd      do i=1,nn
6524 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6525 cd      enddo
6526         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6527           msglen=msglen2
6528             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6529 C Clear the contacts of the atom passed to the neighboring processor
6530         nn=num_cont_hb(iatel_s+1)
6531 cd      do i=1,nn
6532 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6533 cd      enddo
6534             num_cont_hb(iatel_s)=0
6535         endif
6536 cd      write (iout,*) 'Processor ',MyID,MyRank,
6537 cd   & ' is sending correlation contribution to processor',MyID-1,
6538 cd   & ' msglen=',msglen
6539 cd      write (*,*) 'Processor ',MyID,MyRank,
6540 cd   & ' is sending correlation contribution to processor',MyID-1,
6541 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6542         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6543 cd      write (iout,*) 'Processor ',MyID,
6544 cd   & ' has sent correlation contribution to processor',MyID-1,
6545 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6546 cd      write (*,*) 'Processor ',MyID,
6547 cd   & ' has sent correlation contribution to processor',MyID-1,
6548 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6549         msglen=msglen1
6550       endif ! (MyRank.gt.0)
6551       if (ldone) goto 30
6552       ldone=.true.
6553    20 continue
6554 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6555       if (MyRank.lt.fgProcs-1) then
6556 C Receive correlation contributions from the next processor
6557         msglen=msglen1
6558         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6559 cd      write (iout,*) 'Processor',MyID,
6560 cd   & ' is receiving correlation contribution from processor',MyID+1,
6561 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6562 cd      write (*,*) 'Processor',MyID,
6563 cd   & ' is receiving correlation contribution from processor',MyID+1,
6564 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6565         nbytes=-1
6566         do while (nbytes.le.0)
6567           call mp_probe(MyID+1,CorrelType,nbytes)
6568         enddo
6569 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6570         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6571 cd      write (iout,*) 'Processor',MyID,
6572 cd   & ' has received correlation contribution from processor',MyID+1,
6573 cd   & ' msglen=',msglen,' nbytes=',nbytes
6574 cd      write (iout,*) 'The received BUFFER array:'
6575 cd      do i=1,max_cont
6576 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6577 cd      enddo
6578         if (msglen.eq.msglen1) then
6579           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6580         else if (msglen.eq.msglen2)  then
6581           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6582           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6583         else
6584           write (iout,*)
6585      & 'ERROR!!!! message length changed while processing correlations.'
6586           write (*,*)
6587      & 'ERROR!!!! message length changed while processing correlations.'
6588           call mp_stopall(Error)
6589         endif ! msglen.eq.msglen1
6590       endif ! MyRank.lt.fgProcs-1
6591       if (ldone) goto 30
6592       ldone=.true.
6593       goto 10
6594    30 continue
6595 #endif
6596       if (lprn) then
6597         write (iout,'(a)') 'Contact function values:'
6598         do i=nnt,nct-2
6599           write (iout,'(2i3,50(1x,i2,f5.2))')
6600      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6601      &    j=1,num_cont_hb(i))
6602         enddo
6603       endif
6604       ecorr=0.0D0
6605 C Remove the loop below after debugging !!!
6606       do i=nnt,nct
6607         do j=1,3
6608           gradcorr(j,i)=0.0D0
6609           gradxorr(j,i)=0.0D0
6610         enddo
6611       enddo
6612 C Calculate the local-electrostatic correlation terms
6613       do i=iatel_s,iatel_e+1
6614         i1=i+1
6615         num_conti=num_cont_hb(i)
6616         num_conti1=num_cont_hb(i+1)
6617         do jj=1,num_conti
6618           j=jcont_hb(jj,i)
6619           do kk=1,num_conti1
6620             j1=jcont_hb(kk,i1)
6621 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6622 c     &         ' jj=',jj,' kk=',kk
6623             if (j1.eq.j+1 .or. j1.eq.j-1) then
6624 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6625 C The system gains extra energy.
6626               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6627               n_corr=n_corr+1
6628             else if (j1.eq.j) then
6629 C Contacts I-J and I-(J+1) occur simultaneously.
6630 C The system loses extra energy.
6631 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6632             endif
6633           enddo ! kk
6634           do kk=1,num_conti
6635             j1=jcont_hb(kk,i)
6636 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6637 c    &         ' jj=',jj,' kk=',kk
6638             if (j1.eq.j+1) then
6639 C Contacts I-J and (I+1)-J occur simultaneously.
6640 C The system loses extra energy.
6641 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6642             endif ! j1==j+1
6643           enddo ! kk
6644         enddo ! jj
6645       enddo ! i
6646       return
6647       end
6648 c------------------------------------------------------------------------------
6649       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6650      &  n_corr1)
6651 C This subroutine calculates multi-body contributions to hydrogen-bonding
6652       implicit real*8 (a-h,o-z)
6653       include 'DIMENSIONS'
6654       include 'DIMENSIONS.ZSCOPT'
6655       include 'COMMON.IOUNITS'
6656 #ifdef MPL
6657       include 'COMMON.INFO'
6658 #endif
6659       include 'COMMON.FFIELD'
6660       include 'COMMON.DERIV'
6661       include 'COMMON.INTERACT'
6662       include 'COMMON.CONTACTS'
6663 #ifdef MPL
6664       parameter (max_cont=maxconts)
6665       parameter (max_dim=2*(8*3+2))
6666       parameter (msglen1=max_cont*max_dim*4)
6667       parameter (msglen2=2*msglen1)
6668       integer source,CorrelType,CorrelID,Error
6669       double precision buffer(max_cont,max_dim)
6670 #endif
6671       double precision gx(3),gx1(3)
6672       logical lprn,ldone
6673
6674 C Set lprn=.true. for debugging
6675       lprn=.false.
6676       eturn6=0.0d0
6677 #ifdef MPL
6678       n_corr=0
6679       n_corr1=0
6680       if (fgProcs.le.1) goto 30
6681       if (lprn) then
6682         write (iout,'(a)') 'Contact function values:'
6683         do i=nnt,nct-2
6684           write (iout,'(2i3,50(1x,i2,f5.2))')
6685      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6686      &    j=1,num_cont_hb(i))
6687         enddo
6688       endif
6689 C Caution! Following code assumes that electrostatic interactions concerning
6690 C a given atom are split among at most two processors!
6691       CorrelType=477
6692       CorrelID=MyID+1
6693       ldone=.false.
6694       do i=1,max_cont
6695         do j=1,max_dim
6696           buffer(i,j)=0.0D0
6697         enddo
6698       enddo
6699       mm=mod(MyRank,2)
6700 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6701       if (mm) 20,20,10
6702    10 continue
6703 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6704       if (MyRank.gt.0) then
6705 C Send correlation contributions to the preceding processor
6706         msglen=msglen1
6707         nn=num_cont_hb(iatel_s)
6708         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6709 cd      write (iout,*) 'The BUFFER array:'
6710 cd      do i=1,nn
6711 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6712 cd      enddo
6713         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6714           msglen=msglen2
6715             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6716 C Clear the contacts of the atom passed to the neighboring processor
6717         nn=num_cont_hb(iatel_s+1)
6718 cd      do i=1,nn
6719 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6720 cd      enddo
6721             num_cont_hb(iatel_s)=0
6722         endif
6723 cd      write (iout,*) 'Processor ',MyID,MyRank,
6724 cd   & ' is sending correlation contribution to processor',MyID-1,
6725 cd   & ' msglen=',msglen
6726 cd      write (*,*) 'Processor ',MyID,MyRank,
6727 cd   & ' is sending correlation contribution to processor',MyID-1,
6728 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6729         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6730 cd      write (iout,*) 'Processor ',MyID,
6731 cd   & ' has sent correlation contribution to processor',MyID-1,
6732 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6733 cd      write (*,*) 'Processor ',MyID,
6734 cd   & ' has sent correlation contribution to processor',MyID-1,
6735 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6736         msglen=msglen1
6737       endif ! (MyRank.gt.0)
6738       if (ldone) goto 30
6739       ldone=.true.
6740    20 continue
6741 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6742       if (MyRank.lt.fgProcs-1) then
6743 C Receive correlation contributions from the next processor
6744         msglen=msglen1
6745         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6746 cd      write (iout,*) 'Processor',MyID,
6747 cd   & ' is receiving correlation contribution from processor',MyID+1,
6748 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6749 cd      write (*,*) 'Processor',MyID,
6750 cd   & ' is receiving correlation contribution from processor',MyID+1,
6751 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6752         nbytes=-1
6753         do while (nbytes.le.0)
6754           call mp_probe(MyID+1,CorrelType,nbytes)
6755         enddo
6756 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6757         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6758 cd      write (iout,*) 'Processor',MyID,
6759 cd   & ' has received correlation contribution from processor',MyID+1,
6760 cd   & ' msglen=',msglen,' nbytes=',nbytes
6761 cd      write (iout,*) 'The received BUFFER array:'
6762 cd      do i=1,max_cont
6763 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6764 cd      enddo
6765         if (msglen.eq.msglen1) then
6766           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6767         else if (msglen.eq.msglen2)  then
6768           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6769           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6770         else
6771           write (iout,*)
6772      & 'ERROR!!!! message length changed while processing correlations.'
6773           write (*,*)
6774      & 'ERROR!!!! message length changed while processing correlations.'
6775           call mp_stopall(Error)
6776         endif ! msglen.eq.msglen1
6777       endif ! MyRank.lt.fgProcs-1
6778       if (ldone) goto 30
6779       ldone=.true.
6780       goto 10
6781    30 continue
6782 #endif
6783       if (lprn) then
6784         write (iout,'(a)') 'Contact function values:'
6785         do i=nnt,nct-2
6786           write (iout,'(2i3,50(1x,i2,f5.2))')
6787      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6788      &    j=1,num_cont_hb(i))
6789         enddo
6790       endif
6791       ecorr=0.0D0
6792       ecorr5=0.0d0
6793       ecorr6=0.0d0
6794 C Remove the loop below after debugging !!!
6795       do i=nnt,nct
6796         do j=1,3
6797           gradcorr(j,i)=0.0D0
6798           gradxorr(j,i)=0.0D0
6799         enddo
6800       enddo
6801 C Calculate the dipole-dipole interaction energies
6802       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6803       do i=iatel_s,iatel_e+1
6804         num_conti=num_cont_hb(i)
6805         do jj=1,num_conti
6806           j=jcont_hb(jj,i)
6807           call dipole(i,j,jj)
6808         enddo
6809       enddo
6810       endif
6811 C Calculate the local-electrostatic correlation terms
6812       do i=iatel_s,iatel_e+1
6813         i1=i+1
6814         num_conti=num_cont_hb(i)
6815         num_conti1=num_cont_hb(i+1)
6816         do jj=1,num_conti
6817           j=jcont_hb(jj,i)
6818           do kk=1,num_conti1
6819             j1=jcont_hb(kk,i1)
6820 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6821 c     &         ' jj=',jj,' kk=',kk
6822             if (j1.eq.j+1 .or. j1.eq.j-1) then
6823 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6824 C The system gains extra energy.
6825               n_corr=n_corr+1
6826               sqd1=dsqrt(d_cont(jj,i))
6827               sqd2=dsqrt(d_cont(kk,i1))
6828               sred_geom = sqd1*sqd2
6829               IF (sred_geom.lt.cutoff_corr) THEN
6830                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6831      &            ekont,fprimcont)
6832 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6833 c     &         ' jj=',jj,' kk=',kk
6834                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6835                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6836                 do l=1,3
6837                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6838                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6839                 enddo
6840                 n_corr1=n_corr1+1
6841 cd               write (iout,*) 'sred_geom=',sred_geom,
6842 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6843                 call calc_eello(i,j,i+1,j1,jj,kk)
6844                 if (wcorr4.gt.0.0d0)
6845      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6846                 if (wcorr5.gt.0.0d0)
6847      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6848 c                print *,"wcorr5",ecorr5
6849 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6850 cd                write(2,*)'ijkl',i,j,i+1,j1
6851                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6852      &               .or. wturn6.eq.0.0d0))then
6853 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6854                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6855 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6856 cd     &            'ecorr6=',ecorr6
6857 cd                write (iout,'(4e15.5)') sred_geom,
6858 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6859 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6860 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6861                 else if (wturn6.gt.0.0d0
6862      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6863 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6864                   eturn6=eturn6+eello_turn6(i,jj,kk)
6865 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6866                 endif
6867               ENDIF
6868 1111          continue
6869             else if (j1.eq.j) then
6870 C Contacts I-J and I-(J+1) occur simultaneously.
6871 C The system loses extra energy.
6872 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6873             endif
6874           enddo ! kk
6875           do kk=1,num_conti
6876             j1=jcont_hb(kk,i)
6877 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6878 c    &         ' jj=',jj,' kk=',kk
6879             if (j1.eq.j+1) then
6880 C Contacts I-J and (I+1)-J occur simultaneously.
6881 C The system loses extra energy.
6882 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6883             endif ! j1==j+1
6884           enddo ! kk
6885         enddo ! jj
6886       enddo ! i
6887       return
6888       end
6889 c------------------------------------------------------------------------------
6890       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6891       implicit real*8 (a-h,o-z)
6892       include 'DIMENSIONS'
6893       include 'COMMON.IOUNITS'
6894       include 'COMMON.DERIV'
6895       include 'COMMON.INTERACT'
6896       include 'COMMON.CONTACTS'
6897       double precision gx(3),gx1(3)
6898       logical lprn
6899       lprn=.false.
6900       eij=facont_hb(jj,i)
6901       ekl=facont_hb(kk,k)
6902       ees0pij=ees0p(jj,i)
6903       ees0pkl=ees0p(kk,k)
6904       ees0mij=ees0m(jj,i)
6905       ees0mkl=ees0m(kk,k)
6906       ekont=eij*ekl
6907       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6908 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6909 C Following 4 lines for diagnostics.
6910 cd    ees0pkl=0.0D0
6911 cd    ees0pij=1.0D0
6912 cd    ees0mkl=0.0D0
6913 cd    ees0mij=1.0D0
6914 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6915 c    &   ' and',k,l
6916 c     write (iout,*)'Contacts have occurred for peptide groups',
6917 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6918 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6919 C Calculate the multi-body contribution to energy.
6920       ecorr=ecorr+ekont*ees
6921       if (calc_grad) then
6922 C Calculate multi-body contributions to the gradient.
6923       do ll=1,3
6924         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6925         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6926      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6927      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6928         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6929      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6930      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6931         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6932         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6933      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6934      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6935         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6936      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6937      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6938       enddo
6939       do m=i+1,j-1
6940         do ll=1,3
6941           gradcorr(ll,m)=gradcorr(ll,m)+
6942      &     ees*ekl*gacont_hbr(ll,jj,i)-
6943      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6944      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6945         enddo
6946       enddo
6947       do m=k+1,l-1
6948         do ll=1,3
6949           gradcorr(ll,m)=gradcorr(ll,m)+
6950      &     ees*eij*gacont_hbr(ll,kk,k)-
6951      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6952      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6953         enddo
6954       enddo
6955       endif
6956       ehbcorr=ekont*ees
6957       return
6958       end
6959 C---------------------------------------------------------------------------
6960       subroutine dipole(i,j,jj)
6961       implicit real*8 (a-h,o-z)
6962       include 'DIMENSIONS'
6963       include 'DIMENSIONS.ZSCOPT'
6964       include 'COMMON.IOUNITS'
6965       include 'COMMON.CHAIN'
6966       include 'COMMON.FFIELD'
6967       include 'COMMON.DERIV'
6968       include 'COMMON.INTERACT'
6969       include 'COMMON.CONTACTS'
6970       include 'COMMON.TORSION'
6971       include 'COMMON.VAR'
6972       include 'COMMON.GEO'
6973       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6974      &  auxmat(2,2)
6975       iti1 = itortyp(itype(i+1))
6976       if (j.lt.nres-1) then
6977         itj1 = itortyp(itype(j+1))
6978       else
6979         itj1=ntortyp+1
6980       endif
6981       do iii=1,2
6982         dipi(iii,1)=Ub2(iii,i)
6983         dipderi(iii)=Ub2der(iii,i)
6984         dipi(iii,2)=b1(iii,iti1)
6985         dipj(iii,1)=Ub2(iii,j)
6986         dipderj(iii)=Ub2der(iii,j)
6987         dipj(iii,2)=b1(iii,itj1)
6988       enddo
6989       kkk=0
6990       do iii=1,2
6991         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6992         do jjj=1,2
6993           kkk=kkk+1
6994           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6995         enddo
6996       enddo
6997       if (.not.calc_grad) return
6998       do kkk=1,5
6999         do lll=1,3
7000           mmm=0
7001           do iii=1,2
7002             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7003      &        auxvec(1))
7004             do jjj=1,2
7005               mmm=mmm+1
7006               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7007             enddo
7008           enddo
7009         enddo
7010       enddo
7011       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7012       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7013       do iii=1,2
7014         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7015       enddo
7016       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7017       do iii=1,2
7018         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7019       enddo
7020       return
7021       end
7022 C---------------------------------------------------------------------------
7023       subroutine calc_eello(i,j,k,l,jj,kk)
7024 C
7025 C This subroutine computes matrices and vectors needed to calculate
7026 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7027 C
7028       implicit real*8 (a-h,o-z)
7029       include 'DIMENSIONS'
7030       include 'DIMENSIONS.ZSCOPT'
7031       include 'COMMON.IOUNITS'
7032       include 'COMMON.CHAIN'
7033       include 'COMMON.DERIV'
7034       include 'COMMON.INTERACT'
7035       include 'COMMON.CONTACTS'
7036       include 'COMMON.TORSION'
7037       include 'COMMON.VAR'
7038       include 'COMMON.GEO'
7039       include 'COMMON.FFIELD'
7040       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7041      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7042       logical lprn
7043       common /kutas/ lprn
7044 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7045 cd     & ' jj=',jj,' kk=',kk
7046 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7047       do iii=1,2
7048         do jjj=1,2
7049           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7050           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7051         enddo
7052       enddo
7053       call transpose2(aa1(1,1),aa1t(1,1))
7054       call transpose2(aa2(1,1),aa2t(1,1))
7055       do kkk=1,5
7056         do lll=1,3
7057           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7058      &      aa1tder(1,1,lll,kkk))
7059           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7060      &      aa2tder(1,1,lll,kkk))
7061         enddo
7062       enddo
7063       if (l.eq.j+1) then
7064 C parallel orientation of the two CA-CA-CA frames.
7065         if (i.gt.1) then
7066           iti=itortyp(itype(i))
7067         else
7068           iti=ntortyp+1
7069         endif
7070         itk1=itortyp(itype(k+1))
7071         itj=itortyp(itype(j))
7072         if (l.lt.nres-1) then
7073           itl1=itortyp(itype(l+1))
7074         else
7075           itl1=ntortyp+1
7076         endif
7077 C A1 kernel(j+1) A2T
7078 cd        do iii=1,2
7079 cd          write (iout,'(3f10.5,5x,3f10.5)')
7080 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7081 cd        enddo
7082         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7083      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7084      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7085 C Following matrices are needed only for 6-th order cumulants
7086         IF (wcorr6.gt.0.0d0) THEN
7087         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7088      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7089      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7090         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7091      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7092      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7093      &   ADtEAderx(1,1,1,1,1,1))
7094         lprn=.false.
7095         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7096      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7097      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7098      &   ADtEA1derx(1,1,1,1,1,1))
7099         ENDIF
7100 C End 6-th order cumulants
7101 cd        lprn=.false.
7102 cd        if (lprn) then
7103 cd        write (2,*) 'In calc_eello6'
7104 cd        do iii=1,2
7105 cd          write (2,*) 'iii=',iii
7106 cd          do kkk=1,5
7107 cd            write (2,*) 'kkk=',kkk
7108 cd            do jjj=1,2
7109 cd              write (2,'(3(2f10.5),5x)')
7110 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7111 cd            enddo
7112 cd          enddo
7113 cd        enddo
7114 cd        endif
7115         call transpose2(EUgder(1,1,k),auxmat(1,1))
7116         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7117         call transpose2(EUg(1,1,k),auxmat(1,1))
7118         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7119         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7120         do iii=1,2
7121           do kkk=1,5
7122             do lll=1,3
7123               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7124      &          EAEAderx(1,1,lll,kkk,iii,1))
7125             enddo
7126           enddo
7127         enddo
7128 C A1T kernel(i+1) A2
7129         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7130      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7131      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7132 C Following matrices are needed only for 6-th order cumulants
7133         IF (wcorr6.gt.0.0d0) THEN
7134         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7135      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7136      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7137         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7138      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7139      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7140      &   ADtEAderx(1,1,1,1,1,2))
7141         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7142      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7143      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7144      &   ADtEA1derx(1,1,1,1,1,2))
7145         ENDIF
7146 C End 6-th order cumulants
7147         call transpose2(EUgder(1,1,l),auxmat(1,1))
7148         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7149         call transpose2(EUg(1,1,l),auxmat(1,1))
7150         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7151         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7152         do iii=1,2
7153           do kkk=1,5
7154             do lll=1,3
7155               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7156      &          EAEAderx(1,1,lll,kkk,iii,2))
7157             enddo
7158           enddo
7159         enddo
7160 C AEAb1 and AEAb2
7161 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7162 C They are needed only when the fifth- or the sixth-order cumulants are
7163 C indluded.
7164         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7165         call transpose2(AEA(1,1,1),auxmat(1,1))
7166         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7167         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7168         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7169         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7170         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7171         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7172         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7173         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7174         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7175         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7176         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7177         call transpose2(AEA(1,1,2),auxmat(1,1))
7178         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7179         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7180         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7181         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7182         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7183         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7184         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7185         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7186         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7187         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7188         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7189 C Calculate the Cartesian derivatives of the vectors.
7190         do iii=1,2
7191           do kkk=1,5
7192             do lll=1,3
7193               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7194               call matvec2(auxmat(1,1),b1(1,iti),
7195      &          AEAb1derx(1,lll,kkk,iii,1,1))
7196               call matvec2(auxmat(1,1),Ub2(1,i),
7197      &          AEAb2derx(1,lll,kkk,iii,1,1))
7198               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7199      &          AEAb1derx(1,lll,kkk,iii,2,1))
7200               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7201      &          AEAb2derx(1,lll,kkk,iii,2,1))
7202               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7203               call matvec2(auxmat(1,1),b1(1,itj),
7204      &          AEAb1derx(1,lll,kkk,iii,1,2))
7205               call matvec2(auxmat(1,1),Ub2(1,j),
7206      &          AEAb2derx(1,lll,kkk,iii,1,2))
7207               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7208      &          AEAb1derx(1,lll,kkk,iii,2,2))
7209               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7210      &          AEAb2derx(1,lll,kkk,iii,2,2))
7211             enddo
7212           enddo
7213         enddo
7214         ENDIF
7215 C End vectors
7216       else
7217 C Antiparallel orientation of the two CA-CA-CA frames.
7218         if (i.gt.1) then
7219           iti=itortyp(itype(i))
7220         else
7221           iti=ntortyp+1
7222         endif
7223         itk1=itortyp(itype(k+1))
7224         itl=itortyp(itype(l))
7225         itj=itortyp(itype(j))
7226         if (j.lt.nres-1) then
7227           itj1=itortyp(itype(j+1))
7228         else
7229           itj1=ntortyp+1
7230         endif
7231 C A2 kernel(j-1)T A1T
7232         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7233      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7234      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7235 C Following matrices are needed only for 6-th order cumulants
7236         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7237      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7238         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7239      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7240      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7241         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7242      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7243      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7244      &   ADtEAderx(1,1,1,1,1,1))
7245         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7246      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7247      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7248      &   ADtEA1derx(1,1,1,1,1,1))
7249         ENDIF
7250 C End 6-th order cumulants
7251         call transpose2(EUgder(1,1,k),auxmat(1,1))
7252         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7253         call transpose2(EUg(1,1,k),auxmat(1,1))
7254         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7255         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7256         do iii=1,2
7257           do kkk=1,5
7258             do lll=1,3
7259               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7260      &          EAEAderx(1,1,lll,kkk,iii,1))
7261             enddo
7262           enddo
7263         enddo
7264 C A2T kernel(i+1)T A1
7265         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7266      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7267      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7268 C Following matrices are needed only for 6-th order cumulants
7269         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7270      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7271         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7272      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7273      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7274         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7275      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7276      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7277      &   ADtEAderx(1,1,1,1,1,2))
7278         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7279      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7280      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7281      &   ADtEA1derx(1,1,1,1,1,2))
7282         ENDIF
7283 C End 6-th order cumulants
7284         call transpose2(EUgder(1,1,j),auxmat(1,1))
7285         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7286         call transpose2(EUg(1,1,j),auxmat(1,1))
7287         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7288         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7289         do iii=1,2
7290           do kkk=1,5
7291             do lll=1,3
7292               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7293      &          EAEAderx(1,1,lll,kkk,iii,2))
7294             enddo
7295           enddo
7296         enddo
7297 C AEAb1 and AEAb2
7298 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7299 C They are needed only when the fifth- or the sixth-order cumulants are
7300 C indluded.
7301         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7302      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7303         call transpose2(AEA(1,1,1),auxmat(1,1))
7304         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7305         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7306         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7307         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7308         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7309         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7310         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7311         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7312         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7313         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7314         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7315         call transpose2(AEA(1,1,2),auxmat(1,1))
7316         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7317         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7318         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7319         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7320         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7321         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7322         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7323         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7324         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7325         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7326         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7327 C Calculate the Cartesian derivatives of the vectors.
7328         do iii=1,2
7329           do kkk=1,5
7330             do lll=1,3
7331               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7332               call matvec2(auxmat(1,1),b1(1,iti),
7333      &          AEAb1derx(1,lll,kkk,iii,1,1))
7334               call matvec2(auxmat(1,1),Ub2(1,i),
7335      &          AEAb2derx(1,lll,kkk,iii,1,1))
7336               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7337      &          AEAb1derx(1,lll,kkk,iii,2,1))
7338               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7339      &          AEAb2derx(1,lll,kkk,iii,2,1))
7340               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7341               call matvec2(auxmat(1,1),b1(1,itl),
7342      &          AEAb1derx(1,lll,kkk,iii,1,2))
7343               call matvec2(auxmat(1,1),Ub2(1,l),
7344      &          AEAb2derx(1,lll,kkk,iii,1,2))
7345               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7346      &          AEAb1derx(1,lll,kkk,iii,2,2))
7347               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7348      &          AEAb2derx(1,lll,kkk,iii,2,2))
7349             enddo
7350           enddo
7351         enddo
7352         ENDIF
7353 C End vectors
7354       endif
7355       return
7356       end
7357 C---------------------------------------------------------------------------
7358       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7359      &  KK,KKderg,AKA,AKAderg,AKAderx)
7360       implicit none
7361       integer nderg
7362       logical transp
7363       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7364      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7365      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7366       integer iii,kkk,lll
7367       integer jjj,mmm
7368       logical lprn
7369       common /kutas/ lprn
7370       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7371       do iii=1,nderg
7372         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7373      &    AKAderg(1,1,iii))
7374       enddo
7375 cd      if (lprn) write (2,*) 'In kernel'
7376       do kkk=1,5
7377 cd        if (lprn) write (2,*) 'kkk=',kkk
7378         do lll=1,3
7379           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7380      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7381 cd          if (lprn) then
7382 cd            write (2,*) 'lll=',lll
7383 cd            write (2,*) 'iii=1'
7384 cd            do jjj=1,2
7385 cd              write (2,'(3(2f10.5),5x)')
7386 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7387 cd            enddo
7388 cd          endif
7389           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7390      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7391 cd          if (lprn) then
7392 cd            write (2,*) 'lll=',lll
7393 cd            write (2,*) 'iii=2'
7394 cd            do jjj=1,2
7395 cd              write (2,'(3(2f10.5),5x)')
7396 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7397 cd            enddo
7398 cd          endif
7399         enddo
7400       enddo
7401       return
7402       end
7403 C---------------------------------------------------------------------------
7404       double precision function eello4(i,j,k,l,jj,kk)
7405       implicit real*8 (a-h,o-z)
7406       include 'DIMENSIONS'
7407       include 'DIMENSIONS.ZSCOPT'
7408       include 'COMMON.IOUNITS'
7409       include 'COMMON.CHAIN'
7410       include 'COMMON.DERIV'
7411       include 'COMMON.INTERACT'
7412       include 'COMMON.CONTACTS'
7413       include 'COMMON.TORSION'
7414       include 'COMMON.VAR'
7415       include 'COMMON.GEO'
7416       double precision pizda(2,2),ggg1(3),ggg2(3)
7417 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7418 cd        eello4=0.0d0
7419 cd        return
7420 cd      endif
7421 cd      print *,'eello4:',i,j,k,l,jj,kk
7422 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7423 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7424 cold      eij=facont_hb(jj,i)
7425 cold      ekl=facont_hb(kk,k)
7426 cold      ekont=eij*ekl
7427       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7428       if (calc_grad) then
7429 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7430       gcorr_loc(k-1)=gcorr_loc(k-1)
7431      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7432       if (l.eq.j+1) then
7433         gcorr_loc(l-1)=gcorr_loc(l-1)
7434      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7435       else
7436         gcorr_loc(j-1)=gcorr_loc(j-1)
7437      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7438       endif
7439       do iii=1,2
7440         do kkk=1,5
7441           do lll=1,3
7442             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7443      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7444 cd            derx(lll,kkk,iii)=0.0d0
7445           enddo
7446         enddo
7447       enddo
7448 cd      gcorr_loc(l-1)=0.0d0
7449 cd      gcorr_loc(j-1)=0.0d0
7450 cd      gcorr_loc(k-1)=0.0d0
7451 cd      eel4=1.0d0
7452 cd      write (iout,*)'Contacts have occurred for peptide groups',
7453 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7454 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7455       if (j.lt.nres-1) then
7456         j1=j+1
7457         j2=j-1
7458       else
7459         j1=j-1
7460         j2=j-2
7461       endif
7462       if (l.lt.nres-1) then
7463         l1=l+1
7464         l2=l-1
7465       else
7466         l1=l-1
7467         l2=l-2
7468       endif
7469       do ll=1,3
7470 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
7471         ggg1(ll)=eel4*g_contij(ll,1)
7472         ggg2(ll)=eel4*g_contij(ll,2)
7473         ghalf=0.5d0*ggg1(ll)
7474 cd        ghalf=0.0d0
7475         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
7476         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7477         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
7478         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7479 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
7480         ghalf=0.5d0*ggg2(ll)
7481 cd        ghalf=0.0d0
7482         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
7483         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7484         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
7485         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7486       enddo
7487 cd      goto 1112
7488       do m=i+1,j-1
7489         do ll=1,3
7490 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
7491           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7492         enddo
7493       enddo
7494       do m=k+1,l-1
7495         do ll=1,3
7496 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
7497           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7498         enddo
7499       enddo
7500 1112  continue
7501       do m=i+2,j2
7502         do ll=1,3
7503           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7504         enddo
7505       enddo
7506       do m=k+2,l2
7507         do ll=1,3
7508           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7509         enddo
7510       enddo
7511 cd      do iii=1,nres-3
7512 cd        write (2,*) iii,gcorr_loc(iii)
7513 cd      enddo
7514       endif
7515       eello4=ekont*eel4
7516 cd      write (2,*) 'ekont',ekont
7517 cd      write (iout,*) 'eello4',ekont*eel4
7518       return
7519       end
7520 C---------------------------------------------------------------------------
7521       double precision function eello5(i,j,k,l,jj,kk)
7522       implicit real*8 (a-h,o-z)
7523       include 'DIMENSIONS'
7524       include 'DIMENSIONS.ZSCOPT'
7525       include 'COMMON.IOUNITS'
7526       include 'COMMON.CHAIN'
7527       include 'COMMON.DERIV'
7528       include 'COMMON.INTERACT'
7529       include 'COMMON.CONTACTS'
7530       include 'COMMON.TORSION'
7531       include 'COMMON.VAR'
7532       include 'COMMON.GEO'
7533       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7534       double precision ggg1(3),ggg2(3)
7535 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7536 C                                                                              C
7537 C                            Parallel chains                                   C
7538 C                                                                              C
7539 C          o             o                   o             o                   C
7540 C         /l\           / \             \   / \           / \   /              C
7541 C        /   \         /   \             \ /   \         /   \ /               C
7542 C       j| o |l1       | o |              o| o |         | o |o                C
7543 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7544 C      \i/   \         /   \ /             /   \         /   \                 C
7545 C       o    k1             o                                                  C
7546 C         (I)          (II)                (III)          (IV)                 C
7547 C                                                                              C
7548 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7549 C                                                                              C
7550 C                            Antiparallel chains                               C
7551 C                                                                              C
7552 C          o             o                   o             o                   C
7553 C         /j\           / \             \   / \           / \   /              C
7554 C        /   \         /   \             \ /   \         /   \ /               C
7555 C      j1| o |l        | o |              o| o |         | o |o                C
7556 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7557 C      \i/   \         /   \ /             /   \         /   \                 C
7558 C       o     k1            o                                                  C
7559 C         (I)          (II)                (III)          (IV)                 C
7560 C                                                                              C
7561 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7562 C                                                                              C
7563 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7564 C                                                                              C
7565 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7566 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7567 cd        eello5=0.0d0
7568 cd        return
7569 cd      endif
7570 cd      write (iout,*)
7571 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7572 cd     &   ' and',k,l
7573       itk=itortyp(itype(k))
7574       itl=itortyp(itype(l))
7575       itj=itortyp(itype(j))
7576       eello5_1=0.0d0
7577       eello5_2=0.0d0
7578       eello5_3=0.0d0
7579       eello5_4=0.0d0
7580 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7581 cd     &   eel5_3_num,eel5_4_num)
7582       do iii=1,2
7583         do kkk=1,5
7584           do lll=1,3
7585             derx(lll,kkk,iii)=0.0d0
7586           enddo
7587         enddo
7588       enddo
7589 cd      eij=facont_hb(jj,i)
7590 cd      ekl=facont_hb(kk,k)
7591 cd      ekont=eij*ekl
7592 cd      write (iout,*)'Contacts have occurred for peptide groups',
7593 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7594 cd      goto 1111
7595 C Contribution from the graph I.
7596 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7597 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7598       call transpose2(EUg(1,1,k),auxmat(1,1))
7599       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7600       vv(1)=pizda(1,1)-pizda(2,2)
7601       vv(2)=pizda(1,2)+pizda(2,1)
7602       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7603      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7604       if (calc_grad) then
7605 C Explicit gradient in virtual-dihedral angles.
7606       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7607      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7608      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7609       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7610       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7611       vv(1)=pizda(1,1)-pizda(2,2)
7612       vv(2)=pizda(1,2)+pizda(2,1)
7613       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7614      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7615      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7616       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7617       vv(1)=pizda(1,1)-pizda(2,2)
7618       vv(2)=pizda(1,2)+pizda(2,1)
7619       if (l.eq.j+1) then
7620         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7621      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7622      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7623       else
7624         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7625      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7626      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7627       endif
7628 C Cartesian gradient
7629       do iii=1,2
7630         do kkk=1,5
7631           do lll=1,3
7632             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7633      &        pizda(1,1))
7634             vv(1)=pizda(1,1)-pizda(2,2)
7635             vv(2)=pizda(1,2)+pizda(2,1)
7636             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7637      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7638      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7639           enddo
7640         enddo
7641       enddo
7642 c      goto 1112
7643       endif
7644 c1111  continue
7645 C Contribution from graph II
7646       call transpose2(EE(1,1,itk),auxmat(1,1))
7647       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7648       vv(1)=pizda(1,1)+pizda(2,2)
7649       vv(2)=pizda(2,1)-pizda(1,2)
7650       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7651      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7652       if (calc_grad) then
7653 C Explicit gradient in virtual-dihedral angles.
7654       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7655      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7656       call matmat2(auxmat(1,1),AEAderg(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       if (l.eq.j+1) then
7660         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7661      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7662      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7663       else
7664         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7665      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7666      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7667       endif
7668 C Cartesian gradient
7669       do iii=1,2
7670         do kkk=1,5
7671           do lll=1,3
7672             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7673      &        pizda(1,1))
7674             vv(1)=pizda(1,1)+pizda(2,2)
7675             vv(2)=pizda(2,1)-pizda(1,2)
7676             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7677      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7678      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7679           enddo
7680         enddo
7681       enddo
7682 cd      goto 1112
7683       endif
7684 cd1111  continue
7685       if (l.eq.j+1) then
7686 cd        goto 1110
7687 C Parallel orientation
7688 C Contribution from graph III
7689         call transpose2(EUg(1,1,l),auxmat(1,1))
7690         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7691         vv(1)=pizda(1,1)-pizda(2,2)
7692         vv(2)=pizda(1,2)+pizda(2,1)
7693         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7694      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7695         if (calc_grad) then
7696 C Explicit gradient in virtual-dihedral angles.
7697         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7698      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7699      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7700         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7701         vv(1)=pizda(1,1)-pizda(2,2)
7702         vv(2)=pizda(1,2)+pizda(2,1)
7703         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7704      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7705      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7706         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7707         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7708         vv(1)=pizda(1,1)-pizda(2,2)
7709         vv(2)=pizda(1,2)+pizda(2,1)
7710         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7711      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7712      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7713 C Cartesian gradient
7714         do iii=1,2
7715           do kkk=1,5
7716             do lll=1,3
7717               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7718      &          pizda(1,1))
7719               vv(1)=pizda(1,1)-pizda(2,2)
7720               vv(2)=pizda(1,2)+pizda(2,1)
7721               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7722      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7723      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7724             enddo
7725           enddo
7726         enddo
7727 cd        goto 1112
7728         endif
7729 C Contribution from graph IV
7730 cd1110    continue
7731         call transpose2(EE(1,1,itl),auxmat(1,1))
7732         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7733         vv(1)=pizda(1,1)+pizda(2,2)
7734         vv(2)=pizda(2,1)-pizda(1,2)
7735         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7736      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7737         if (calc_grad) then
7738 C Explicit gradient in virtual-dihedral angles.
7739         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7740      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7741         call matmat2(auxmat(1,1),AEAderg(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         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7745      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7746      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7747 C Cartesian gradient
7748         do iii=1,2
7749           do kkk=1,5
7750             do lll=1,3
7751               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7752      &          pizda(1,1))
7753               vv(1)=pizda(1,1)+pizda(2,2)
7754               vv(2)=pizda(2,1)-pizda(1,2)
7755               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7756      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7757      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7758             enddo
7759           enddo
7760         enddo
7761         endif
7762       else
7763 C Antiparallel orientation
7764 C Contribution from graph III
7765 c        goto 1110
7766         call transpose2(EUg(1,1,j),auxmat(1,1))
7767         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7768         vv(1)=pizda(1,1)-pizda(2,2)
7769         vv(2)=pizda(1,2)+pizda(2,1)
7770         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7771      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7772         if (calc_grad) then
7773 C Explicit gradient in virtual-dihedral angles.
7774         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7775      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7776      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7777         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7778         vv(1)=pizda(1,1)-pizda(2,2)
7779         vv(2)=pizda(1,2)+pizda(2,1)
7780         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7781      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7782      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7783         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7784         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7785         vv(1)=pizda(1,1)-pizda(2,2)
7786         vv(2)=pizda(1,2)+pizda(2,1)
7787         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7788      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7789      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7790 C Cartesian gradient
7791         do iii=1,2
7792           do kkk=1,5
7793             do lll=1,3
7794               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7795      &          pizda(1,1))
7796               vv(1)=pizda(1,1)-pizda(2,2)
7797               vv(2)=pizda(1,2)+pizda(2,1)
7798               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7799      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7800      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7801             enddo
7802           enddo
7803         enddo
7804 cd        goto 1112
7805         endif
7806 C Contribution from graph IV
7807 1110    continue
7808         call transpose2(EE(1,1,itj),auxmat(1,1))
7809         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7810         vv(1)=pizda(1,1)+pizda(2,2)
7811         vv(2)=pizda(2,1)-pizda(1,2)
7812         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7813      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7814         if (calc_grad) then
7815 C Explicit gradient in virtual-dihedral angles.
7816         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7817      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7818         call matmat2(auxmat(1,1),AEAderg(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         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7822      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7823      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7824 C Cartesian gradient
7825         do iii=1,2
7826           do kkk=1,5
7827             do lll=1,3
7828               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7829      &          pizda(1,1))
7830               vv(1)=pizda(1,1)+pizda(2,2)
7831               vv(2)=pizda(2,1)-pizda(1,2)
7832               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7833      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7834      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7835             enddo
7836           enddo
7837         enddo
7838       endif
7839       endif
7840 1112  continue
7841       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7842 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7843 cd        write (2,*) 'ijkl',i,j,k,l
7844 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7845 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7846 cd      endif
7847 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7848 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7849 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7850 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7851       if (calc_grad) then
7852       if (j.lt.nres-1) then
7853         j1=j+1
7854         j2=j-1
7855       else
7856         j1=j-1
7857         j2=j-2
7858       endif
7859       if (l.lt.nres-1) then
7860         l1=l+1
7861         l2=l-1
7862       else
7863         l1=l-1
7864         l2=l-2
7865       endif
7866 cd      eij=1.0d0
7867 cd      ekl=1.0d0
7868 cd      ekont=1.0d0
7869 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7870       do ll=1,3
7871         ggg1(ll)=eel5*g_contij(ll,1)
7872         ggg2(ll)=eel5*g_contij(ll,2)
7873 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7874         ghalf=0.5d0*ggg1(ll)
7875 cd        ghalf=0.0d0
7876         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7877         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7878         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7879         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7880 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7881         ghalf=0.5d0*ggg2(ll)
7882 cd        ghalf=0.0d0
7883         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7884         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7885         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7886         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7887       enddo
7888 cd      goto 1112
7889       do m=i+1,j-1
7890         do ll=1,3
7891 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7892           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7893         enddo
7894       enddo
7895       do m=k+1,l-1
7896         do ll=1,3
7897 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7898           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7899         enddo
7900       enddo
7901 c1112  continue
7902       do m=i+2,j2
7903         do ll=1,3
7904           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7905         enddo
7906       enddo
7907       do m=k+2,l2
7908         do ll=1,3
7909           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7910         enddo
7911       enddo
7912 cd      do iii=1,nres-3
7913 cd        write (2,*) iii,g_corr5_loc(iii)
7914 cd      enddo
7915       endif
7916       eello5=ekont*eel5
7917 cd      write (2,*) 'ekont',ekont
7918 cd      write (iout,*) 'eello5',ekont*eel5
7919       return
7920       end
7921 c--------------------------------------------------------------------------
7922       double precision function eello6(i,j,k,l,jj,kk)
7923       implicit real*8 (a-h,o-z)
7924       include 'DIMENSIONS'
7925       include 'DIMENSIONS.ZSCOPT'
7926       include 'COMMON.IOUNITS'
7927       include 'COMMON.CHAIN'
7928       include 'COMMON.DERIV'
7929       include 'COMMON.INTERACT'
7930       include 'COMMON.CONTACTS'
7931       include 'COMMON.TORSION'
7932       include 'COMMON.VAR'
7933       include 'COMMON.GEO'
7934       include 'COMMON.FFIELD'
7935       double precision ggg1(3),ggg2(3)
7936 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7937 cd        eello6=0.0d0
7938 cd        return
7939 cd      endif
7940 cd      write (iout,*)
7941 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7942 cd     &   ' and',k,l
7943       eello6_1=0.0d0
7944       eello6_2=0.0d0
7945       eello6_3=0.0d0
7946       eello6_4=0.0d0
7947       eello6_5=0.0d0
7948       eello6_6=0.0d0
7949 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7950 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7951       do iii=1,2
7952         do kkk=1,5
7953           do lll=1,3
7954             derx(lll,kkk,iii)=0.0d0
7955           enddo
7956         enddo
7957       enddo
7958 cd      eij=facont_hb(jj,i)
7959 cd      ekl=facont_hb(kk,k)
7960 cd      ekont=eij*ekl
7961 cd      eij=1.0d0
7962 cd      ekl=1.0d0
7963 cd      ekont=1.0d0
7964       if (l.eq.j+1) then
7965         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7966         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7967         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7968         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7969         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7970         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7971       else
7972         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7973         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7974         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7975         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7976         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7977           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7978         else
7979           eello6_5=0.0d0
7980         endif
7981         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7982       endif
7983 C If turn contributions are considered, they will be handled separately.
7984       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7985 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7986 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7987 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7988 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7989 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7990 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7991 cd      goto 1112
7992       if (calc_grad) then
7993       if (j.lt.nres-1) then
7994         j1=j+1
7995         j2=j-1
7996       else
7997         j1=j-1
7998         j2=j-2
7999       endif
8000       if (l.lt.nres-1) then
8001         l1=l+1
8002         l2=l-1
8003       else
8004         l1=l-1
8005         l2=l-2
8006       endif
8007       do ll=1,3
8008         ggg1(ll)=eel6*g_contij(ll,1)
8009         ggg2(ll)=eel6*g_contij(ll,2)
8010 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8011         ghalf=0.5d0*ggg1(ll)
8012 cd        ghalf=0.0d0
8013         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
8014         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8015         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
8016         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8017         ghalf=0.5d0*ggg2(ll)
8018 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8019 cd        ghalf=0.0d0
8020         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
8021         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8022         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
8023         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8024       enddo
8025 cd      goto 1112
8026       do m=i+1,j-1
8027         do ll=1,3
8028 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8029           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8030         enddo
8031       enddo
8032       do m=k+1,l-1
8033         do ll=1,3
8034 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8035           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8036         enddo
8037       enddo
8038 1112  continue
8039       do m=i+2,j2
8040         do ll=1,3
8041           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8042         enddo
8043       enddo
8044       do m=k+2,l2
8045         do ll=1,3
8046           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8047         enddo
8048       enddo
8049 cd      do iii=1,nres-3
8050 cd        write (2,*) iii,g_corr6_loc(iii)
8051 cd      enddo
8052       endif
8053       eello6=ekont*eel6
8054 cd      write (2,*) 'ekont',ekont
8055 cd      write (iout,*) 'eello6',ekont*eel6
8056       return
8057       end
8058 c--------------------------------------------------------------------------
8059       double precision function eello6_graph1(i,j,k,l,imat,swap)
8060       implicit real*8 (a-h,o-z)
8061       include 'DIMENSIONS'
8062       include 'DIMENSIONS.ZSCOPT'
8063       include 'COMMON.IOUNITS'
8064       include 'COMMON.CHAIN'
8065       include 'COMMON.DERIV'
8066       include 'COMMON.INTERACT'
8067       include 'COMMON.CONTACTS'
8068       include 'COMMON.TORSION'
8069       include 'COMMON.VAR'
8070       include 'COMMON.GEO'
8071       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8072       logical swap
8073       logical lprn
8074       common /kutas/ lprn
8075 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8076 C                                                                              C
8077 C      Parallel       Antiparallel                                             C
8078 C                                                                              C
8079 C          o             o                                                     C
8080 C         /l\           /j\                                                    C
8081 C        /   \         /   \                                                   C
8082 C       /| o |         | o |\                                                  C
8083 C     \ j|/k\|  /   \  |/k\|l /                                                C
8084 C      \ /   \ /     \ /   \ /                                                 C
8085 C       o     o       o     o                                                  C
8086 C       i             i                                                        C
8087 C                                                                              C
8088 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8089       itk=itortyp(itype(k))
8090       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8091       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8092       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8093       call transpose2(EUgC(1,1,k),auxmat(1,1))
8094       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8095       vv1(1)=pizda1(1,1)-pizda1(2,2)
8096       vv1(2)=pizda1(1,2)+pizda1(2,1)
8097       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8098       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8099       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8100       s5=scalar2(vv(1),Dtobr2(1,i))
8101 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8102       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8103       if (.not. calc_grad) return
8104       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8105      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8106      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8107      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8108      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8109      & +scalar2(vv(1),Dtobr2der(1,i)))
8110       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8111       vv1(1)=pizda1(1,1)-pizda1(2,2)
8112       vv1(2)=pizda1(1,2)+pizda1(2,1)
8113       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8114       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8115       if (l.eq.j+1) then
8116         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8117      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8118      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8119      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8120      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8121       else
8122         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8123      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8124      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8125      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8126      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8127       endif
8128       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8129       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8130       vv1(1)=pizda1(1,1)-pizda1(2,2)
8131       vv1(2)=pizda1(1,2)+pizda1(2,1)
8132       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8133      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8134      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8135      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8136       do iii=1,2
8137         if (swap) then
8138           ind=3-iii
8139         else
8140           ind=iii
8141         endif
8142         do kkk=1,5
8143           do lll=1,3
8144             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8145             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8146             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8147             call transpose2(EUgC(1,1,k),auxmat(1,1))
8148             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8149      &        pizda1(1,1))
8150             vv1(1)=pizda1(1,1)-pizda1(2,2)
8151             vv1(2)=pizda1(1,2)+pizda1(2,1)
8152             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8153             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8154      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8155             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8156      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8157             s5=scalar2(vv(1),Dtobr2(1,i))
8158             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8159           enddo
8160         enddo
8161       enddo
8162       return
8163       end
8164 c----------------------------------------------------------------------------
8165       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8166       implicit real*8 (a-h,o-z)
8167       include 'DIMENSIONS'
8168       include 'DIMENSIONS.ZSCOPT'
8169       include 'COMMON.IOUNITS'
8170       include 'COMMON.CHAIN'
8171       include 'COMMON.DERIV'
8172       include 'COMMON.INTERACT'
8173       include 'COMMON.CONTACTS'
8174       include 'COMMON.TORSION'
8175       include 'COMMON.VAR'
8176       include 'COMMON.GEO'
8177       logical swap
8178       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8179      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8180       logical lprn
8181       common /kutas/ lprn
8182 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8183 C                                                                              C
8184 C      Parallel       Antiparallel                                             C
8185 C                                                                              C
8186 C          o             o                                                     C
8187 C     \   /l\           /j\   /                                                C
8188 C      \ /   \         /   \ /                                                 C
8189 C       o| o |         | o |o                                                  C
8190 C     \ j|/k\|      \  |/k\|l                                                  C
8191 C      \ /   \       \ /   \                                                   C
8192 C       o             o                                                        C
8193 C       i             i                                                        C
8194 C                                                                              C
8195 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8196 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8197 C AL 7/4/01 s1 would occur in the sixth-order moment,
8198 C           but not in a cluster cumulant
8199 #ifdef MOMENT
8200       s1=dip(1,jj,i)*dip(1,kk,k)
8201 #endif
8202       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8203       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8204       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8205       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8206       call transpose2(EUg(1,1,k),auxmat(1,1))
8207       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8208       vv(1)=pizda(1,1)-pizda(2,2)
8209       vv(2)=pizda(1,2)+pizda(2,1)
8210       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8211 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8212 #ifdef MOMENT
8213       eello6_graph2=-(s1+s2+s3+s4)
8214 #else
8215       eello6_graph2=-(s2+s3+s4)
8216 #endif
8217 c      eello6_graph2=-s3
8218       if (.not. calc_grad) return
8219 C Derivatives in gamma(i-1)
8220       if (i.gt.1) then
8221 #ifdef MOMENT
8222         s1=dipderg(1,jj,i)*dip(1,kk,k)
8223 #endif
8224         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8225         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8226         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8227         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8228 #ifdef MOMENT
8229         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8230 #else
8231         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8232 #endif
8233 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8234       endif
8235 C Derivatives in gamma(k-1)
8236 #ifdef MOMENT
8237       s1=dip(1,jj,i)*dipderg(1,kk,k)
8238 #endif
8239       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8240       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8241       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8242       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8243       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8244       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8245       vv(1)=pizda(1,1)-pizda(2,2)
8246       vv(2)=pizda(1,2)+pizda(2,1)
8247       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8248 #ifdef MOMENT
8249       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8250 #else
8251       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8252 #endif
8253 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8254 C Derivatives in gamma(j-1) or gamma(l-1)
8255       if (j.gt.1) then
8256 #ifdef MOMENT
8257         s1=dipderg(3,jj,i)*dip(1,kk,k)
8258 #endif
8259         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8260         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8261         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8262         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8263         vv(1)=pizda(1,1)-pizda(2,2)
8264         vv(2)=pizda(1,2)+pizda(2,1)
8265         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8266 #ifdef MOMENT
8267         if (swap) then
8268           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8269         else
8270           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8271         endif
8272 #endif
8273         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8274 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8275       endif
8276 C Derivatives in gamma(l-1) or gamma(j-1)
8277       if (l.gt.1) then
8278 #ifdef MOMENT
8279         s1=dip(1,jj,i)*dipderg(3,kk,k)
8280 #endif
8281         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8282         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8283         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8284         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8285         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8286         vv(1)=pizda(1,1)-pizda(2,2)
8287         vv(2)=pizda(1,2)+pizda(2,1)
8288         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8289 #ifdef MOMENT
8290         if (swap) then
8291           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8292         else
8293           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8294         endif
8295 #endif
8296         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8297 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8298       endif
8299 C Cartesian derivatives.
8300       if (lprn) then
8301         write (2,*) 'In eello6_graph2'
8302         do iii=1,2
8303           write (2,*) 'iii=',iii
8304           do kkk=1,5
8305             write (2,*) 'kkk=',kkk
8306             do jjj=1,2
8307               write (2,'(3(2f10.5),5x)')
8308      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8309             enddo
8310           enddo
8311         enddo
8312       endif
8313       do iii=1,2
8314         do kkk=1,5
8315           do lll=1,3
8316 #ifdef MOMENT
8317             if (iii.eq.1) then
8318               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8319             else
8320               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8321             endif
8322 #endif
8323             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8324      &        auxvec(1))
8325             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8326             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8327      &        auxvec(1))
8328             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8329             call transpose2(EUg(1,1,k),auxmat(1,1))
8330             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8331      &        pizda(1,1))
8332             vv(1)=pizda(1,1)-pizda(2,2)
8333             vv(2)=pizda(1,2)+pizda(2,1)
8334             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8335 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8336 #ifdef MOMENT
8337             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8338 #else
8339             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8340 #endif
8341             if (swap) then
8342               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8343             else
8344               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8345             endif
8346           enddo
8347         enddo
8348       enddo
8349       return
8350       end
8351 c----------------------------------------------------------------------------
8352       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8353       implicit real*8 (a-h,o-z)
8354       include 'DIMENSIONS'
8355       include 'DIMENSIONS.ZSCOPT'
8356       include 'COMMON.IOUNITS'
8357       include 'COMMON.CHAIN'
8358       include 'COMMON.DERIV'
8359       include 'COMMON.INTERACT'
8360       include 'COMMON.CONTACTS'
8361       include 'COMMON.TORSION'
8362       include 'COMMON.VAR'
8363       include 'COMMON.GEO'
8364       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8365       logical swap
8366 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8367 C                                                                              C
8368 C      Parallel       Antiparallel                                             C
8369 C                                                                              C
8370 C          o             o                                                     C
8371 C         /l\   /   \   /j\                                                    C
8372 C        /   \ /     \ /   \                                                   C
8373 C       /| o |o       o| o |\                                                  C
8374 C       j|/k\|  /      |/k\|l /                                                C
8375 C        /   \ /       /   \ /                                                 C
8376 C       /     o       /     o                                                  C
8377 C       i             i                                                        C
8378 C                                                                              C
8379 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8380 C
8381 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8382 C           energy moment and not to the cluster cumulant.
8383       iti=itortyp(itype(i))
8384       if (j.lt.nres-1) then
8385         itj1=itortyp(itype(j+1))
8386       else
8387         itj1=ntortyp+1
8388       endif
8389       itk=itortyp(itype(k))
8390       itk1=itortyp(itype(k+1))
8391       if (l.lt.nres-1) then
8392         itl1=itortyp(itype(l+1))
8393       else
8394         itl1=ntortyp+1
8395       endif
8396 #ifdef MOMENT
8397       s1=dip(4,jj,i)*dip(4,kk,k)
8398 #endif
8399       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8400       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8401       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8402       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8403       call transpose2(EE(1,1,itk),auxmat(1,1))
8404       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8405       vv(1)=pizda(1,1)+pizda(2,2)
8406       vv(2)=pizda(2,1)-pizda(1,2)
8407       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8408 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8409 #ifdef MOMENT
8410       eello6_graph3=-(s1+s2+s3+s4)
8411 #else
8412       eello6_graph3=-(s2+s3+s4)
8413 #endif
8414 c      eello6_graph3=-s4
8415       if (.not. calc_grad) return
8416 C Derivatives in gamma(k-1)
8417       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8418       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8419       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8420       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8421 C Derivatives in gamma(l-1)
8422       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8423       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8424       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8425       vv(1)=pizda(1,1)+pizda(2,2)
8426       vv(2)=pizda(2,1)-pizda(1,2)
8427       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8428       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8429 C Cartesian derivatives.
8430       do iii=1,2
8431         do kkk=1,5
8432           do lll=1,3
8433 #ifdef MOMENT
8434             if (iii.eq.1) then
8435               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8436             else
8437               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8438             endif
8439 #endif
8440             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8441      &        auxvec(1))
8442             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8443             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8444      &        auxvec(1))
8445             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8446             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8447      &        pizda(1,1))
8448             vv(1)=pizda(1,1)+pizda(2,2)
8449             vv(2)=pizda(2,1)-pizda(1,2)
8450             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8451 #ifdef MOMENT
8452             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8453 #else
8454             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8455 #endif
8456             if (swap) then
8457               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8458             else
8459               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8460             endif
8461 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8462           enddo
8463         enddo
8464       enddo
8465       return
8466       end
8467 c----------------------------------------------------------------------------
8468       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8469       implicit real*8 (a-h,o-z)
8470       include 'DIMENSIONS'
8471       include 'DIMENSIONS.ZSCOPT'
8472       include 'COMMON.IOUNITS'
8473       include 'COMMON.CHAIN'
8474       include 'COMMON.DERIV'
8475       include 'COMMON.INTERACT'
8476       include 'COMMON.CONTACTS'
8477       include 'COMMON.TORSION'
8478       include 'COMMON.VAR'
8479       include 'COMMON.GEO'
8480       include 'COMMON.FFIELD'
8481       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8482      & auxvec1(2),auxmat1(2,2)
8483       logical swap
8484 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8485 C                                                                              C
8486 C      Parallel       Antiparallel                                             C
8487 C                                                                              C
8488 C          o             o                                                     C
8489 C         /l\   /   \   /j\                                                    C
8490 C        /   \ /     \ /   \                                                   C
8491 C       /| o |o       o| o |\                                                  C
8492 C     \ j|/k\|      \  |/k\|l                                                  C
8493 C      \ /   \       \ /   \                                                   C
8494 C       o     \       o     \                                                  C
8495 C       i             i                                                        C
8496 C                                                                              C
8497 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8498 C
8499 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8500 C           energy moment and not to the cluster cumulant.
8501 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8502       iti=itortyp(itype(i))
8503       itj=itortyp(itype(j))
8504       if (j.lt.nres-1) then
8505         itj1=itortyp(itype(j+1))
8506       else
8507         itj1=ntortyp+1
8508       endif
8509       itk=itortyp(itype(k))
8510       if (k.lt.nres-1) then
8511         itk1=itortyp(itype(k+1))
8512       else
8513         itk1=ntortyp+1
8514       endif
8515       itl=itortyp(itype(l))
8516       if (l.lt.nres-1) then
8517         itl1=itortyp(itype(l+1))
8518       else
8519         itl1=ntortyp+1
8520       endif
8521 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8522 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8523 cd     & ' itl',itl,' itl1',itl1
8524 #ifdef MOMENT
8525       if (imat.eq.1) then
8526         s1=dip(3,jj,i)*dip(3,kk,k)
8527       else
8528         s1=dip(2,jj,j)*dip(2,kk,l)
8529       endif
8530 #endif
8531       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8532       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8533       if (j.eq.l+1) then
8534         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8535         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8536       else
8537         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8538         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8539       endif
8540       call transpose2(EUg(1,1,k),auxmat(1,1))
8541       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8542       vv(1)=pizda(1,1)-pizda(2,2)
8543       vv(2)=pizda(2,1)+pizda(1,2)
8544       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8545 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8546 #ifdef MOMENT
8547       eello6_graph4=-(s1+s2+s3+s4)
8548 #else
8549       eello6_graph4=-(s2+s3+s4)
8550 #endif
8551       if (.not. calc_grad) return
8552 C Derivatives in gamma(i-1)
8553       if (i.gt.1) then
8554 #ifdef MOMENT
8555         if (imat.eq.1) then
8556           s1=dipderg(2,jj,i)*dip(3,kk,k)
8557         else
8558           s1=dipderg(4,jj,j)*dip(2,kk,l)
8559         endif
8560 #endif
8561         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8562         if (j.eq.l+1) then
8563           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8564           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8565         else
8566           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8567           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8568         endif
8569         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8570         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8571 cd          write (2,*) 'turn6 derivatives'
8572 #ifdef MOMENT
8573           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8574 #else
8575           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8576 #endif
8577         else
8578 #ifdef MOMENT
8579           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8580 #else
8581           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8582 #endif
8583         endif
8584       endif
8585 C Derivatives in gamma(k-1)
8586 #ifdef MOMENT
8587       if (imat.eq.1) then
8588         s1=dip(3,jj,i)*dipderg(2,kk,k)
8589       else
8590         s1=dip(2,jj,j)*dipderg(4,kk,l)
8591       endif
8592 #endif
8593       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8594       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8595       if (j.eq.l+1) then
8596         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8597         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8598       else
8599         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8600         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8601       endif
8602       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8603       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8604       vv(1)=pizda(1,1)-pizda(2,2)
8605       vv(2)=pizda(2,1)+pizda(1,2)
8606       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8607       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8608 #ifdef MOMENT
8609         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8610 #else
8611         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8612 #endif
8613       else
8614 #ifdef MOMENT
8615         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8616 #else
8617         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8618 #endif
8619       endif
8620 C Derivatives in gamma(j-1) or gamma(l-1)
8621       if (l.eq.j+1 .and. l.gt.1) then
8622         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8623         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8624         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8625         vv(1)=pizda(1,1)-pizda(2,2)
8626         vv(2)=pizda(2,1)+pizda(1,2)
8627         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8628         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8629       else if (j.gt.1) then
8630         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8631         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8632         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8633         vv(1)=pizda(1,1)-pizda(2,2)
8634         vv(2)=pizda(2,1)+pizda(1,2)
8635         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8636         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8637           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8638         else
8639           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8640         endif
8641       endif
8642 C Cartesian derivatives.
8643       do iii=1,2
8644         do kkk=1,5
8645           do lll=1,3
8646 #ifdef MOMENT
8647             if (iii.eq.1) then
8648               if (imat.eq.1) then
8649                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8650               else
8651                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8652               endif
8653             else
8654               if (imat.eq.1) then
8655                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8656               else
8657                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8658               endif
8659             endif
8660 #endif
8661             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8662      &        auxvec(1))
8663             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8664             if (j.eq.l+1) then
8665               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8666      &          b1(1,itj1),auxvec(1))
8667               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8668             else
8669               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8670      &          b1(1,itl1),auxvec(1))
8671               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8672             endif
8673             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8674      &        pizda(1,1))
8675             vv(1)=pizda(1,1)-pizda(2,2)
8676             vv(2)=pizda(2,1)+pizda(1,2)
8677             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8678             if (swap) then
8679               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8680 #ifdef MOMENT
8681                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8682      &             -(s1+s2+s4)
8683 #else
8684                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8685      &             -(s2+s4)
8686 #endif
8687                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8688               else
8689 #ifdef MOMENT
8690                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8691 #else
8692                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8693 #endif
8694                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8695               endif
8696             else
8697 #ifdef MOMENT
8698               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8699 #else
8700               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8701 #endif
8702               if (l.eq.j+1) then
8703                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8704               else
8705                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8706               endif
8707             endif
8708           enddo
8709         enddo
8710       enddo
8711       return
8712       end
8713 c----------------------------------------------------------------------------
8714       double precision function eello_turn6(i,jj,kk)
8715       implicit real*8 (a-h,o-z)
8716       include 'DIMENSIONS'
8717       include 'DIMENSIONS.ZSCOPT'
8718       include 'COMMON.IOUNITS'
8719       include 'COMMON.CHAIN'
8720       include 'COMMON.DERIV'
8721       include 'COMMON.INTERACT'
8722       include 'COMMON.CONTACTS'
8723       include 'COMMON.TORSION'
8724       include 'COMMON.VAR'
8725       include 'COMMON.GEO'
8726       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8727      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8728      &  ggg1(3),ggg2(3)
8729       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8730      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8731 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8732 C           the respective energy moment and not to the cluster cumulant.
8733       eello_turn6=0.0d0
8734       j=i+4
8735       k=i+1
8736       l=i+3
8737       iti=itortyp(itype(i))
8738       itk=itortyp(itype(k))
8739       itk1=itortyp(itype(k+1))
8740       itl=itortyp(itype(l))
8741       itj=itortyp(itype(j))
8742 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8743 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8744 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8745 cd        eello6=0.0d0
8746 cd        return
8747 cd      endif
8748 cd      write (iout,*)
8749 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8750 cd     &   ' and',k,l
8751 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8752       do iii=1,2
8753         do kkk=1,5
8754           do lll=1,3
8755             derx_turn(lll,kkk,iii)=0.0d0
8756           enddo
8757         enddo
8758       enddo
8759 cd      eij=1.0d0
8760 cd      ekl=1.0d0
8761 cd      ekont=1.0d0
8762       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8763 cd      eello6_5=0.0d0
8764 cd      write (2,*) 'eello6_5',eello6_5
8765 #ifdef MOMENT
8766       call transpose2(AEA(1,1,1),auxmat(1,1))
8767       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8768       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8769       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8770 #else
8771       s1 = 0.0d0
8772 #endif
8773       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8774       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8775       s2 = scalar2(b1(1,itk),vtemp1(1))
8776 #ifdef MOMENT
8777       call transpose2(AEA(1,1,2),atemp(1,1))
8778       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8779       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8780       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8781 #else
8782       s8=0.0d0
8783 #endif
8784       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8785       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8786       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8787 #ifdef MOMENT
8788       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8789       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8790       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8791       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8792       ss13 = scalar2(b1(1,itk),vtemp4(1))
8793       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8794 #else
8795       s13=0.0d0
8796 #endif
8797 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8798 c      s1=0.0d0
8799 c      s2=0.0d0
8800 c      s8=0.0d0
8801 c      s12=0.0d0
8802 c      s13=0.0d0
8803       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8804       if (calc_grad) then
8805 C Derivatives in gamma(i+2)
8806 #ifdef MOMENT
8807       call transpose2(AEA(1,1,1),auxmatd(1,1))
8808       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8809       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8810       call transpose2(AEAderg(1,1,2),atempd(1,1))
8811       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8812       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8813 #else
8814       s8d=0.0d0
8815 #endif
8816       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8817       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8818       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8819 c      s1d=0.0d0
8820 c      s2d=0.0d0
8821 c      s8d=0.0d0
8822 c      s12d=0.0d0
8823 c      s13d=0.0d0
8824       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8825 C Derivatives in gamma(i+3)
8826 #ifdef MOMENT
8827       call transpose2(AEA(1,1,1),auxmatd(1,1))
8828       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8829       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8830       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8831 #else
8832       s1d=0.0d0
8833 #endif
8834       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8835       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8836       s2d = scalar2(b1(1,itk),vtemp1d(1))
8837 #ifdef MOMENT
8838       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8839       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8840 #endif
8841       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8842 #ifdef MOMENT
8843       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8844       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8845       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8846 #else
8847       s13d=0.0d0
8848 #endif
8849 c      s1d=0.0d0
8850 c      s2d=0.0d0
8851 c      s8d=0.0d0
8852 c      s12d=0.0d0
8853 c      s13d=0.0d0
8854 #ifdef MOMENT
8855       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8856      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8857 #else
8858       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8859      &               -0.5d0*ekont*(s2d+s12d)
8860 #endif
8861 C Derivatives in gamma(i+4)
8862       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8863       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8864       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8865 #ifdef MOMENT
8866       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8867       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8868       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8869 #else
8870       s13d = 0.0d0
8871 #endif
8872 c      s1d=0.0d0
8873 c      s2d=0.0d0
8874 c      s8d=0.0d0
8875 C      s12d=0.0d0
8876 c      s13d=0.0d0
8877 #ifdef MOMENT
8878       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8879 #else
8880       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8881 #endif
8882 C Derivatives in gamma(i+5)
8883 #ifdef MOMENT
8884       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8885       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8886       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8887 #else
8888       s1d = 0.0d0
8889 #endif
8890       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8891       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8892       s2d = scalar2(b1(1,itk),vtemp1d(1))
8893 #ifdef MOMENT
8894       call transpose2(AEA(1,1,2),atempd(1,1))
8895       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8896       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8897 #else
8898       s8d = 0.0d0
8899 #endif
8900       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8901       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8902 #ifdef MOMENT
8903       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8904       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8905       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8906 #else
8907       s13d = 0.0d0
8908 #endif
8909 c      s1d=0.0d0
8910 c      s2d=0.0d0
8911 c      s8d=0.0d0
8912 c      s12d=0.0d0
8913 c      s13d=0.0d0
8914 #ifdef MOMENT
8915       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8916      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8917 #else
8918       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8919      &               -0.5d0*ekont*(s2d+s12d)
8920 #endif
8921 C Cartesian derivatives
8922       do iii=1,2
8923         do kkk=1,5
8924           do lll=1,3
8925 #ifdef MOMENT
8926             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8927             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8928             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8929 #else
8930             s1d = 0.0d0
8931 #endif
8932             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8933             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8934      &          vtemp1d(1))
8935             s2d = scalar2(b1(1,itk),vtemp1d(1))
8936 #ifdef MOMENT
8937             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8938             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8939             s8d = -(atempd(1,1)+atempd(2,2))*
8940      &           scalar2(cc(1,1,itl),vtemp2(1))
8941 #else
8942             s8d = 0.0d0
8943 #endif
8944             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8945      &           auxmatd(1,1))
8946             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8947             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8948 c      s1d=0.0d0
8949 c      s2d=0.0d0
8950 c      s8d=0.0d0
8951 c      s12d=0.0d0
8952 c      s13d=0.0d0
8953 #ifdef MOMENT
8954             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8955      &        - 0.5d0*(s1d+s2d)
8956 #else
8957             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8958      &        - 0.5d0*s2d
8959 #endif
8960 #ifdef MOMENT
8961             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8962      &        - 0.5d0*(s8d+s12d)
8963 #else
8964             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8965      &        - 0.5d0*s12d
8966 #endif
8967           enddo
8968         enddo
8969       enddo
8970 #ifdef MOMENT
8971       do kkk=1,5
8972         do lll=1,3
8973           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8974      &      achuj_tempd(1,1))
8975           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8976           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8977           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8978           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8979           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8980      &      vtemp4d(1))
8981           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8982           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8983           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8984         enddo
8985       enddo
8986 #endif
8987 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8988 cd     &  16*eel_turn6_num
8989 cd      goto 1112
8990       if (j.lt.nres-1) then
8991         j1=j+1
8992         j2=j-1
8993       else
8994         j1=j-1
8995         j2=j-2
8996       endif
8997       if (l.lt.nres-1) then
8998         l1=l+1
8999         l2=l-1
9000       else
9001         l1=l-1
9002         l2=l-2
9003       endif
9004       do ll=1,3
9005         ggg1(ll)=eel_turn6*g_contij(ll,1)
9006         ggg2(ll)=eel_turn6*g_contij(ll,2)
9007         ghalf=0.5d0*ggg1(ll)
9008 cd        ghalf=0.0d0
9009         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
9010      &    +ekont*derx_turn(ll,2,1)
9011         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9012         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
9013      &    +ekont*derx_turn(ll,4,1)
9014         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9015         ghalf=0.5d0*ggg2(ll)
9016 cd        ghalf=0.0d0
9017         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
9018      &    +ekont*derx_turn(ll,2,2)
9019         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9020         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
9021      &    +ekont*derx_turn(ll,4,2)
9022         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9023       enddo
9024 cd      goto 1112
9025       do m=i+1,j-1
9026         do ll=1,3
9027           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9028         enddo
9029       enddo
9030       do m=k+1,l-1
9031         do ll=1,3
9032           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9033         enddo
9034       enddo
9035 1112  continue
9036       do m=i+2,j2
9037         do ll=1,3
9038           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9039         enddo
9040       enddo
9041       do m=k+2,l2
9042         do ll=1,3
9043           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9044         enddo
9045       enddo
9046 cd      do iii=1,nres-3
9047 cd        write (2,*) iii,g_corr6_loc(iii)
9048 cd      enddo
9049       endif
9050       eello_turn6=ekont*eel_turn6
9051 cd      write (2,*) 'ekont',ekont
9052 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9053       return
9054       end
9055 crc-------------------------------------------------
9056       SUBROUTINE MATVEC2(A1,V1,V2)
9057       implicit real*8 (a-h,o-z)
9058       include 'DIMENSIONS'
9059       DIMENSION A1(2,2),V1(2),V2(2)
9060 c      DO 1 I=1,2
9061 c        VI=0.0
9062 c        DO 3 K=1,2
9063 c    3     VI=VI+A1(I,K)*V1(K)
9064 c        Vaux(I)=VI
9065 c    1 CONTINUE
9066
9067       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9068       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9069
9070       v2(1)=vaux1
9071       v2(2)=vaux2
9072       END
9073 C---------------------------------------
9074       SUBROUTINE MATMAT2(A1,A2,A3)
9075       implicit real*8 (a-h,o-z)
9076       include 'DIMENSIONS'
9077       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9078 c      DIMENSION AI3(2,2)
9079 c        DO  J=1,2
9080 c          A3IJ=0.0
9081 c          DO K=1,2
9082 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9083 c          enddo
9084 c          A3(I,J)=A3IJ
9085 c       enddo
9086 c      enddo
9087
9088       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9089       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9090       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9091       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9092
9093       A3(1,1)=AI3_11
9094       A3(2,1)=AI3_21
9095       A3(1,2)=AI3_12
9096       A3(2,2)=AI3_22
9097       END
9098
9099 c-------------------------------------------------------------------------
9100       double precision function scalar2(u,v)
9101       implicit none
9102       double precision u(2),v(2)
9103       double precision sc
9104       integer i
9105       scalar2=u(1)*v(1)+u(2)*v(2)
9106       return
9107       end
9108
9109 C-----------------------------------------------------------------------------
9110
9111       subroutine transpose2(a,at)
9112       implicit none
9113       double precision a(2,2),at(2,2)
9114       at(1,1)=a(1,1)
9115       at(1,2)=a(2,1)
9116       at(2,1)=a(1,2)
9117       at(2,2)=a(2,2)
9118       return
9119       end
9120 c--------------------------------------------------------------------------
9121       subroutine transpose(n,a,at)
9122       implicit none
9123       integer n,i,j
9124       double precision a(n,n),at(n,n)
9125       do i=1,n
9126         do j=1,n
9127           at(j,i)=a(i,j)
9128         enddo
9129       enddo
9130       return
9131       end
9132 C---------------------------------------------------------------------------
9133       subroutine prodmat3(a1,a2,kk,transp,prod)
9134       implicit none
9135       integer i,j
9136       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9137       logical transp
9138 crc      double precision auxmat(2,2),prod_(2,2)
9139
9140       if (transp) then
9141 crc        call transpose2(kk(1,1),auxmat(1,1))
9142 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9143 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9144
9145            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9146      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9147            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9148      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9149            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9150      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9151            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9152      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9153
9154       else
9155 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9156 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9157
9158            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9159      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9160            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9161      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9162            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9163      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9164            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9165      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9166
9167       endif
9168 c      call transpose2(a2(1,1),a2t(1,1))
9169
9170 crc      print *,transp
9171 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9172 crc      print *,((prod(i,j),i=1,2),j=1,2)
9173
9174       return
9175       end
9176 C-----------------------------------------------------------------------------
9177       double precision function scalar(u,v)
9178       implicit none
9179       double precision u(3),v(3)
9180       double precision sc
9181       integer i
9182       sc=0.0d0
9183       do i=1,3
9184         sc=sc+u(i)*v(i)
9185       enddo
9186       scalar=sc
9187       return
9188       end
9189