source/wham/src-NEWSC-NEWCORR/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15 #ifdef MPL
  16       include 'COMMON.INFO'
  17       external d_vadd
  18       integer ready
  19 #endif
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       double precision fact(6)
  26 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105,106) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw,evdw_t)
  34 cd    print '(a)','Exit ELJ'
  35       goto 107
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw,evdw_t)
  38       goto 107
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw,evdw_t)
  41       goto 107
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw,evdw_t)
  44       goto 107
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw,evdw_t)
  47       goto 107
  48 C New SC-SC potential
  49   106 call emomo(evdw,evdw_p,evdw_m)
  50 C
  51 C Calculate electrostatic (H-bonding) energy of the main chain.
  52 C
  53   107 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  54 C
  55 C Calculate excluded-volume interaction energy between peptide groups
  56 C and side chains.
  57 C
  58       call escp(evdw2,evdw2_14)
  59 c
  60 c Calculate the bond-stretching energy
  61 c
  62       call ebond(estr)
  63 c      write (iout,*) "estr",estr
  64 C
  65 C Calculate the disulfide-bridge and other energy and the contributions
  66 C from other distance constraints.
  67 cd    print *,'Calling EHPB'
  68       call edis(ehpb)
  69 cd    print *,'EHPB exitted succesfully.'
  70 C
  71 C Calculate the virtual-bond-angle energy.
  72 C
  73       call ebend(ebe)
  74 cd    print *,'Bend energy finished.'
  75 C
  76 C Calculate the SC local energy.
  77 C
  78       call esc(escloc)
  79 cd    print *,'SCLOC energy finished.'
  80 C
  81 C Calculate the virtual-bond torsional energy.
  82 C
  83 cd    print *,'nterm=',nterm
  84       call etor(etors,edihcnstr,fact(1))
  85 C
  86 C 6/23/01 Calculate double-torsional energy
  87 C
  88       call etor_d(etors_d,fact(2))
  89 C
  90 C 21/5/07 Calculate local sicdechain correlation energy
  91 C
  92       call eback_sc_corr(esccor)
  93 C
  94 C 12/1/95 Multi-body terms
  95 C
  96       n_corr=0
  97       n_corr1=0
  98       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  99      &    .or. wturn6.gt.0.0d0) then
 100 c         print *,"calling multibody_eello"
 101          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 102 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 103 c         print *,ecorr,ecorr5,ecorr6,eturn6
 104       endif
 105       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 106          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 107       endif
 108 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 109 #ifdef SPLITELE
 110       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 111      & +wvdwpp*evdw1
 112      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 113      & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 114      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 115      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 116      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 117      & +wbond*estr+wsccor*fact(1)*esccor
 118 #else
 119       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 120      & +welec*fact(1)*(ees+evdw1)
 121      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 122      & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 123      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 124      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 125      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 126      & +wbond*estr+wsccor*fact(1)*esccor
 127 #endif
 128       energia(0)=etot
 129       energia(1)=evdw
 130 #ifdef SCP14
 131       energia(2)=evdw2-evdw2_14
 132       energia(17)=evdw2_14
 133 #else
 134       energia(2)=evdw2
 135       energia(17)=0.0d0
 136 #endif
 137 #ifdef SPLITELE
 138       energia(3)=ees
 139       energia(16)=evdw1
 140 #else
 141       energia(3)=ees+evdw1
 142       energia(16)=0.0d0
 143 #endif
 144       energia(4)=ecorr
 145       energia(5)=ecorr5
 146       energia(6)=ecorr6
 147       energia(7)=eel_loc
 148       energia(8)=eello_turn3
 149       energia(9)=eello_turn4
 150       energia(10)=eturn6
 151       energia(11)=ebe
 152       energia(12)=escloc
 153       energia(13)=etors
 154       energia(14)=etors_d
 155       energia(15)=ehpb
 156       energia(18)=estr
 157       energia(19)=esccor
 158       energia(20)=edihcnstr
 159       energia(21)=evdw_t
 160 c detecting NaNQ
 161 #ifdef ISNAN
 162 #ifdef AIX
 163       if (isnan(etot).ne.0) energia(0)=1.0d+99
 164 #else
 165       if (isnan(etot)) energia(0)=1.0d+99
 166 #endif
 167 #else
 168       i=0
 169 #ifdef WINPGI
 170       idumm=proc_proc(etot,i)
 171 #else
 172       call proc_proc(etot,i)
 173 #endif
 174       if(i.eq.1)energia(0)=1.0d+99
 175 #endif
 176 #ifdef MPL
 177 c     endif
 178 #endif
 179       if (calc_grad) then
 180 C
 181 C Sum up the components of the Cartesian gradient.
 182 C
 183 #ifdef SPLITELE
 184       do i=1,nct
 185         do j=1,3
 186           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 187      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 188      &                wbond*gradb(j,i)+
 189      &                wstrain*ghpbc(j,i)+
 190      &                wcorr*fact(3)*gradcorr(j,i)+
 191      &                wel_loc*fact(2)*gel_loc(j,i)+
 192      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 193      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 194      &                wcorr5*fact(4)*gradcorr5(j,i)+
 195      &                wcorr6*fact(5)*gradcorr6(j,i)+
 196      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 197      &                wsccor*fact(2)*gsccorc(j,i)
 198           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 199      &                  wbond*gradbx(j,i)+
 200      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 201      &                  wsccor*fact(2)*gsccorx(j,i)
 202         enddo
 203 #else
 204       do i=1,nct
 205         do j=1,3
 206           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 207      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 208      &                wbond*gradb(j,i)+
 209      &                wcorr*fact(3)*gradcorr(j,i)+
 210      &                wel_loc*fact(2)*gel_loc(j,i)+
 211      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 212      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 213      &                wcorr5*fact(4)*gradcorr5(j,i)+
 214      &                wcorr6*fact(5)*gradcorr6(j,i)+
 215      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 216      &                wsccor*fact(2)*gsccorc(j,i)
 217           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 218      &                  wbond*gradbx(j,i)+
 219      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 220      &                  wsccor*fact(1)*gsccorx(j,i)
 221         enddo
 222 #endif
 223       enddo
 224
 225
 226       do i=1,nres-3
 227         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 228      &   +wcorr5*fact(4)*g_corr5_loc(i)
 229      &   +wcorr6*fact(5)*g_corr6_loc(i)
 230      &   +wturn4*fact(3)*gel_loc_turn4(i)
 231      &   +wturn3*fact(2)*gel_loc_turn3(i)
 232      &   +wturn6*fact(5)*gel_loc_turn6(i)
 233      &   +wel_loc*fact(2)*gel_loc_loc(i)
 234      &   +wsccor*fact(1)*gsccor_loc(i)
 235       enddo
 236       endif
 237       return
 238       end
 239 C------------------------------------------------------------------------
 240       subroutine enerprint(energia,fact)
 241       implicit real*8 (a-h,o-z)
 242       include 'DIMENSIONS'
 243       include 'DIMENSIONS.ZSCOPT'
 244       include 'COMMON.IOUNITS'
 245       include 'COMMON.FFIELD'
 246       include 'COMMON.SBRIDGE'
 247       double precision energia(0:max_ene),fact(6)
 248       etot=energia(0)
 249       evdw=energia(1)+fact(6)*energia(21)
 250 #ifdef SCP14
 251       evdw2=energia(2)+energia(17)
 252 #else
 253       evdw2=energia(2)
 254 #endif
 255       ees=energia(3)
 256 #ifdef SPLITELE
 257       evdw1=energia(16)
 258 #endif
 259       ecorr=energia(4)
 260       ecorr5=energia(5)
 261       ecorr6=energia(6)
 262       eel_loc=energia(7)
 263       eello_turn3=energia(8)
 264       eello_turn4=energia(9)
 265       eello_turn6=energia(10)
 266       ebe=energia(11)
 267       escloc=energia(12)
 268       etors=energia(13)
 269       etors_d=energia(14)
 270       ehpb=energia(15)
 271       esccor=energia(19)
 272       edihcnstr=energia(20)
 273       estr=energia(18)
 274 #ifdef SPLITELE
 275       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 276      &  wvdwpp,
 277      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 278      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 279      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 280      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 281      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 282      &  esccor,wsccor*fact(1),edihcnstr,ebr*nss,etot
 283    10 format (/'Virtual-chain energies:'//
 284      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 285      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 286      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 287      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 288      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 289      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 290      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 291      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 292      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 293      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 294      & ' (SS bridges & dist. cnstr.)'/
 295      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 296      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 297      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 298      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 299      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 300      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 301      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 302      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 303      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 304      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 305      & 'ETOT=  ',1pE16.6,' (total)')
 306 #else
 307       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 308      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 309      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 310      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 311      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 312      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 313      &  edihcnstr,ebr*nss,etot
 314    10 format (/'Virtual-chain energies:'//
 315      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 316      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 317      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 318      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 319      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 320      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 321      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 322      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 323      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 324      & ' (SS bridges & dist. cnstr.)'/
 325      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 326      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 327      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 328      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 329      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 330      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 331      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 332      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 333      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 334      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 335      & 'ETOT=  ',1pE16.6,' (total)')
 336 #endif
 337       return
 338       end
 339 C-----------------------------------------------------------------------
 340       subroutine elj(evdw,evdw_t)
 341 C
 342 C This subroutine calculates the interaction energy of nonbonded side chains
 343 C assuming the LJ potential of interaction.
 344 C
 345       implicit real*8 (a-h,o-z)
 346       include 'DIMENSIONS'
 347       include 'DIMENSIONS.ZSCOPT'
 348       include "DIMENSIONS.COMPAR"
 349       parameter (accur=1.0d-10)
 350       include 'COMMON.GEO'
 351       include 'COMMON.VAR'
 352       include 'COMMON.LOCAL'
 353       include 'COMMON.CHAIN'
 354       include 'COMMON.DERIV'
 355       include 'COMMON.INTERACT'
 356       include 'COMMON.TORSION'
 357       include 'COMMON.ENEPS'
 358       include 'COMMON.SBRIDGE'
 359       include 'COMMON.NAMES'
 360       include 'COMMON.IOUNITS'
 361       include 'COMMON.CONTACTS'
 362       dimension gg(3)
 363       integer icant
 364       external icant
 365 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 366       do i=1,210
 367         do j=1,2
 368           eneps_temp(j,i)=0.0d0
 369         enddo
 370       enddo
 371       evdw=0.0D0
 372       evdw_t=0.0d0
 373       do i=iatsc_s,iatsc_e
 374         itypi=itype(i)
 375         itypi1=itype(i+1)
 376         xi=c(1,nres+i)
 377         yi=c(2,nres+i)
 378         zi=c(3,nres+i)
 379 C Change 12/1/95
 380         num_conti=0
 381 C
 382 C Calculate SC interaction energy.
 383 C
 384         do iint=1,nint_gr(i)
 385 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 386 cd   &                  'iend=',iend(i,iint)
 387           do j=istart(i,iint),iend(i,iint)
 388             itypj=itype(j)
 389             xj=c(1,nres+j)-xi
 390             yj=c(2,nres+j)-yi
 391             zj=c(3,nres+j)-zi
 392 C Change 12/1/95 to calculate four-body interactions
 393             rij=xj*xj+yj*yj+zj*zj
 394             rrij=1.0D0/rij
 395 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 396             eps0ij=eps(itypi,itypj)
 397             fac=rrij**expon2
 398             e1=fac*fac*aa(itypi,itypj)
 399             e2=fac*bb(itypi,itypj)
 400             evdwij=e1+e2
 401             ij=icant(itypi,itypj)
 402             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 403             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 404 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 405 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 406 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 407 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 408 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 409 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 410             if (bb(itypi,itypj).gt.0.0d0) then
 411               evdw=evdw+evdwij
 412             else
 413               evdw_t=evdw_t+evdwij
 414             endif
 415             if (calc_grad) then
 416 C
 417 C Calculate the components of the gradient in DC and X
 418 C
 419             fac=-rrij*(e1+evdwij)
 420             gg(1)=xj*fac
 421             gg(2)=yj*fac
 422             gg(3)=zj*fac
 423             do k=1,3
 424               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 425               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 426             enddo
 427             do k=i,j-1
 428               do l=1,3
 429                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 430               enddo
 431             enddo
 432             endif
 433 C
 434 C 12/1/95, revised on 5/20/97
 435 C
 436 C Calculate the contact function. The ith column of the array JCONT will
 437 C contain the numbers of atoms that make contacts with the atom I (of numbers
 438 C greater than I). The arrays FACONT and GACONT will contain the values of
 439 C the contact function and its derivative.
 440 C
 441 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 442 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 443 C Uncomment next line, if the correlation interactions are contact function only
 444             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 445               rij=dsqrt(rij)
 446               sigij=sigma(itypi,itypj)
 447               r0ij=rs0(itypi,itypj)
 448 C
 449 C Check whether the SC's are not too far to make a contact.
 450 C
 451               rcut=1.5d0*r0ij
 452               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 453 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 454 C
 455               if (fcont.gt.0.0D0) then
 456 C If the SC-SC distance if close to sigma, apply spline.
 457 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 458 cAdam &             fcont1,fprimcont1)
 459 cAdam           fcont1=1.0d0-fcont1
 460 cAdam           if (fcont1.gt.0.0d0) then
 461 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 462 cAdam             fcont=fcont*fcont1
 463 cAdam           endif
 464 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 465 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 466 cga             do k=1,3
 467 cga               gg(k)=gg(k)*eps0ij
 468 cga             enddo
 469 cga             eps0ij=-evdwij*eps0ij
 470 C Uncomment for AL's type of SC correlation interactions.
 471 cadam           eps0ij=-evdwij
 472                 num_conti=num_conti+1
 473                 jcont(num_conti,i)=j
 474                 facont(num_conti,i)=fcont*eps0ij
 475                 fprimcont=eps0ij*fprimcont/rij
 476                 fcont=expon*fcont
 477 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 478 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 479 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 480 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 481                 gacont(1,num_conti,i)=-fprimcont*xj
 482                 gacont(2,num_conti,i)=-fprimcont*yj
 483                 gacont(3,num_conti,i)=-fprimcont*zj
 484 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 485 cd              write (iout,'(2i3,3f10.5)')
 486 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 487               endif
 488             endif
 489           enddo      ! j
 490         enddo        ! iint
 491 C Change 12/1/95
 492         num_cont(i)=num_conti
 493       enddo          ! i
 494       if (calc_grad) then
 495       do i=1,nct
 496         do j=1,3
 497           gvdwc(j,i)=expon*gvdwc(j,i)
 498           gvdwx(j,i)=expon*gvdwx(j,i)
 499         enddo
 500       enddo
 501       endif
 502 C******************************************************************************
 503 C
 504 C                              N O T E !!!
 505 C
 506 C To save time, the factor of EXPON has been extracted from ALL components
 507 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 508 C use!
 509 C
 510 C******************************************************************************
 511       return
 512       end
 513 C-----------------------------------------------------------------------------
 514       subroutine eljk(evdw,evdw_t)
 515 C
 516 C This subroutine calculates the interaction energy of nonbonded side chains
 517 C assuming the LJK potential of interaction.
 518 C
 519       implicit real*8 (a-h,o-z)
 520       include 'DIMENSIONS'
 521       include 'DIMENSIONS.ZSCOPT'
 522       include "DIMENSIONS.COMPAR"
 523       include 'COMMON.GEO'
 524       include 'COMMON.VAR'
 525       include 'COMMON.LOCAL'
 526       include 'COMMON.CHAIN'
 527       include 'COMMON.DERIV'
 528       include 'COMMON.INTERACT'
 529       include 'COMMON.ENEPS'
 530       include 'COMMON.IOUNITS'
 531       include 'COMMON.NAMES'
 532       dimension gg(3)
 533       logical scheck
 534       integer icant
 535       external icant
 536 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 537       do i=1,210
 538         do j=1,2
 539           eneps_temp(j,i)=0.0d0
 540         enddo
 541       enddo
 542       evdw=0.0D0
 543       evdw_t=0.0d0
 544       do i=iatsc_s,iatsc_e
 545         itypi=itype(i)
 546         itypi1=itype(i+1)
 547         xi=c(1,nres+i)
 548         yi=c(2,nres+i)
 549         zi=c(3,nres+i)
 550 C
 551 C Calculate SC interaction energy.
 552 C
 553         do iint=1,nint_gr(i)
 554           do j=istart(i,iint),iend(i,iint)
 555             itypj=itype(j)
 556             xj=c(1,nres+j)-xi
 557             yj=c(2,nres+j)-yi
 558             zj=c(3,nres+j)-zi
 559             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 560             fac_augm=rrij**expon
 561             e_augm=augm(itypi,itypj)*fac_augm
 562             r_inv_ij=dsqrt(rrij)
 563             rij=1.0D0/r_inv_ij
 564             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 565             fac=r_shift_inv**expon
 566             e1=fac*fac*aa(itypi,itypj)
 567             e2=fac*bb(itypi,itypj)
 568             evdwij=e_augm+e1+e2
 569             ij=icant(itypi,itypj)
 570             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 571      &        /dabs(eps(itypi,itypj))
 572             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 573 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 574 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 575 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 576 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 577 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 578 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 579 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 580             if (bb(itypi,itypj).gt.0.0d0) then
 581               evdw=evdw+evdwij
 582             else
 583               evdw_t=evdw_t+evdwij
 584             endif
 585             if (calc_grad) then
 586 C
 587 C Calculate the components of the gradient in DC and X
 588 C
 589             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 590             gg(1)=xj*fac
 591             gg(2)=yj*fac
 592             gg(3)=zj*fac
 593             do k=1,3
 594               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 595               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 596             enddo
 597             do k=i,j-1
 598               do l=1,3
 599                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 600               enddo
 601             enddo
 602             endif
 603           enddo      ! j
 604         enddo        ! iint
 605       enddo          ! i
 606       if (calc_grad) then
 607       do i=1,nct
 608         do j=1,3
 609           gvdwc(j,i)=expon*gvdwc(j,i)
 610           gvdwx(j,i)=expon*gvdwx(j,i)
 611         enddo
 612       enddo
 613       endif
 614       return
 615       end
 616 C-----------------------------------------------------------------------------
 617       subroutine ebp(evdw,evdw_t)
 618 C
 619 C This subroutine calculates the interaction energy of nonbonded side chains
 620 C assuming the Berne-Pechukas potential of interaction.
 621 C
 622       implicit real*8 (a-h,o-z)
 623       include 'DIMENSIONS'
 624       include 'DIMENSIONS.ZSCOPT'
 625       include "DIMENSIONS.COMPAR"
 626       include 'COMMON.GEO'
 627       include 'COMMON.VAR'
 628       include 'COMMON.LOCAL'
 629       include 'COMMON.CHAIN'
 630       include 'COMMON.DERIV'
 631       include 'COMMON.NAMES'
 632       include 'COMMON.INTERACT'
 633       include 'COMMON.ENEPS'
 634       include 'COMMON.IOUNITS'
 635       include 'COMMON.CALC'
 636       common /srutu/ icall
 637 c     double precision rrsave(maxdim)
 638       logical lprn
 639       integer icant
 640       external icant
 641       do i=1,210
 642         do j=1,2
 643           eneps_temp(j,i)=0.0d0
 644         enddo
 645       enddo
 646       evdw=0.0D0
 647       evdw_t=0.0d0
 648 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 649 c     if (icall.eq.0) then
 650 c       lprn=.true.
 651 c     else
 652         lprn=.false.
 653 c     endif
 654       ind=0
 655       do i=iatsc_s,iatsc_e
 656         itypi=itype(i)
 657         itypi1=itype(i+1)
 658         xi=c(1,nres+i)
 659         yi=c(2,nres+i)
 660         zi=c(3,nres+i)
 661         dxi=dc_norm(1,nres+i)
 662         dyi=dc_norm(2,nres+i)
 663         dzi=dc_norm(3,nres+i)
 664         dsci_inv=vbld_inv(i+nres)
 665 C
 666 C Calculate SC interaction energy.
 667 C
 668         do iint=1,nint_gr(i)
 669           do j=istart(i,iint),iend(i,iint)
 670             ind=ind+1
 671             itypj=itype(j)
 672             dscj_inv=vbld_inv(j+nres)
 673             chi1=chi(itypi,itypj)
 674             chi2=chi(itypj,itypi)
 675             chi12=chi1*chi2
 676             chip1=chip(itypi)
 677             chip2=chip(itypj)
 678             chip12=chip1*chip2
 679             alf1=alp(itypi)
 680             alf2=alp(itypj)
 681             alf12=0.5D0*(alf1+alf2)
 682 C For diagnostics only!!!
 683 c           chi1=0.0D0
 684 c           chi2=0.0D0
 685 c           chi12=0.0D0
 686 c           chip1=0.0D0
 687 c           chip2=0.0D0
 688 c           chip12=0.0D0
 689 c           alf1=0.0D0
 690 c           alf2=0.0D0
 691 c           alf12=0.0D0
 692             xj=c(1,nres+j)-xi
 693             yj=c(2,nres+j)-yi
 694             zj=c(3,nres+j)-zi
 695             dxj=dc_norm(1,nres+j)
 696             dyj=dc_norm(2,nres+j)
 697             dzj=dc_norm(3,nres+j)
 698             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 699 cd          if (icall.eq.0) then
 700 cd            rrsave(ind)=rrij
 701 cd          else
 702 cd            rrij=rrsave(ind)
 703 cd          endif
 704             rij=dsqrt(rrij)
 705 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 706             call sc_angular
 707 C Calculate whole angle-dependent part of epsilon and contributions
 708 C to its derivatives
 709             fac=(rrij*sigsq)**expon2
 710             e1=fac*fac*aa(itypi,itypj)
 711             e2=fac*bb(itypi,itypj)
 712             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 713             eps2der=evdwij*eps3rt
 714             eps3der=evdwij*eps2rt
 715             evdwij=evdwij*eps2rt*eps3rt
 716             ij=icant(itypi,itypj)
 717             aux=eps1*eps2rt**2*eps3rt**2
 718             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 719      &        /dabs(eps(itypi,itypj))
 720             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 721             if (bb(itypi,itypj).gt.0.0d0) then
 722               evdw=evdw+evdwij
 723             else
 724               evdw_t=evdw_t+evdwij
 725             endif
 726             if (calc_grad) then
 727             if (lprn) then
 728             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 729             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 730 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 731 cd     &        restyp(itypi),i,restyp(itypj),j,
 732 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 733 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 734 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 735 cd     &        evdwij
 736             endif
 737 C Calculate gradient components.
 738             e1=e1*eps1*eps2rt**2*eps3rt**2
 739             fac=-expon*(e1+evdwij)
 740             sigder=fac/sigsq
 741             fac=rrij*fac
 742 C Calculate radial part of the gradient
 743             gg(1)=xj*fac
 744             gg(2)=yj*fac
 745             gg(3)=zj*fac
 746 C Calculate the angular part of the gradient and sum add the contributions
 747 C to the appropriate components of the Cartesian gradient.
 748             call sc_grad
 749             endif
 750           enddo      ! j
 751         enddo        ! iint
 752       enddo          ! i
 753 c     stop
 754       return
 755       end
 756 C-----------------------------------------------------------------------------
 757       subroutine egb(evdw,evdw_t)
 758 C
 759 C This subroutine calculates the interaction energy of nonbonded side chains
 760 C assuming the Gay-Berne potential of interaction.
 761 C
 762       implicit real*8 (a-h,o-z)
 763       include 'DIMENSIONS'
 764       include 'DIMENSIONS.ZSCOPT'
 765       include "DIMENSIONS.COMPAR"
 766       include 'COMMON.GEO'
 767       include 'COMMON.VAR'
 768       include 'COMMON.LOCAL'
 769       include 'COMMON.CHAIN'
 770       include 'COMMON.DERIV'
 771       include 'COMMON.NAMES'
 772       include 'COMMON.INTERACT'
 773       include 'COMMON.ENEPS'
 774       include 'COMMON.IOUNITS'
 775       include 'COMMON.CALC'
 776       logical lprn
 777       common /srutu/icall
 778       integer icant
 779       external icant
 780       do i=1,210
 781         do j=1,2
 782           eneps_temp(j,i)=0.0d0
 783         enddo
 784       enddo
 785 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 786       evdw=0.0D0
 787       evdw_t=0.0d0
 788       lprn=.false.
 789 c      if (icall.gt.0) lprn=.true.
 790       ind=0
 791       do i=iatsc_s,iatsc_e
 792         itypi=itype(i)
 793         itypi1=itype(i+1)
 794         xi=c(1,nres+i)
 795         yi=c(2,nres+i)
 796         zi=c(3,nres+i)
 797         dxi=dc_norm(1,nres+i)
 798         dyi=dc_norm(2,nres+i)
 799         dzi=dc_norm(3,nres+i)
 800         dsci_inv=vbld_inv(i+nres)
 801 C
 802 C Calculate SC interaction energy.
 803 C
 804         do iint=1,nint_gr(i)
 805           do j=istart(i,iint),iend(i,iint)
 806             ind=ind+1
 807             itypj=itype(j)
 808             dscj_inv=vbld_inv(j+nres)
 809             sig0ij=sigma(itypi,itypj)
 810             chi1=chi(itypi,itypj)
 811             chi2=chi(itypj,itypi)
 812             chi12=chi1*chi2
 813             chip1=chip(itypi)
 814             chip2=chip(itypj)
 815             chip12=chip1*chip2
 816             alf1=alp(itypi)
 817             alf2=alp(itypj)
 818             alf12=0.5D0*(alf1+alf2)
 819 C For diagnostics only!!!
 820 c           chi1=0.0D0
 821 c           chi2=0.0D0
 822 c           chi12=0.0D0
 823 c           chip1=0.0D0
 824 c           chip2=0.0D0
 825 c           chip12=0.0D0
 826 c           alf1=0.0D0
 827 c           alf2=0.0D0
 828 c           alf12=0.0D0
 829             xj=c(1,nres+j)-xi
 830             yj=c(2,nres+j)-yi
 831             zj=c(3,nres+j)-zi
 832             dxj=dc_norm(1,nres+j)
 833             dyj=dc_norm(2,nres+j)
 834             dzj=dc_norm(3,nres+j)
 835 c            write (iout,*) i,j,xj,yj,zj
 836             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 837             rij=dsqrt(rrij)
 838 C Calculate angle-dependent terms of energy and contributions to their
 839 C derivatives.
 840             call sc_angular
 841             sigsq=1.0D0/sigsq
 842             sig=sig0ij*dsqrt(sigsq)
 843             rij_shift=1.0D0/rij-sig+sig0ij
 844 C I hate to put IF's in the loops, but here don't have another choice!!!!
 845             if (rij_shift.le.0.0D0) then
 846               evdw=1.0D20
 847               return
 848             endif
 849             sigder=-sig*sigsq
 850 c---------------------------------------------------------------
 851             rij_shift=1.0D0/rij_shift
 852             fac=rij_shift**expon
 853             e1=fac*fac*aa(itypi,itypj)
 854             e2=fac*bb(itypi,itypj)
 855             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 856             eps2der=evdwij*eps3rt
 857             eps3der=evdwij*eps2rt
 858             evdwij=evdwij*eps2rt*eps3rt
 859             if (bb(itypi,itypj).gt.0) then
 860               evdw=evdw+evdwij
 861             else
 862               evdw_t=evdw_t+evdwij
 863             endif
 864             ij=icant(itypi,itypj)
 865             aux=eps1*eps2rt**2*eps3rt**2
 866             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 867      &        /dabs(eps(itypi,itypj))
 868             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 869 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 870 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 871 c     &         aux*e2/eps(itypi,itypj)
 872             if (lprn) then
 873             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 874             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 875             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 876      &        restyp(itypi),i,restyp(itypj),j,
 877      &        epsi,sigm,chi1,chi2,chip1,chip2,
 878      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 879      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 880      &        evdwij
 881             endif
 882             if (calc_grad) then
 883 C Calculate gradient components.
 884             e1=e1*eps1*eps2rt**2*eps3rt**2
 885             fac=-expon*(e1+evdwij)*rij_shift
 886             sigder=fac*sigder
 887             fac=rij*fac
 888 C Calculate the radial part of the gradient
 889             gg(1)=xj*fac
 890             gg(2)=yj*fac
 891             gg(3)=zj*fac
 892 C Calculate angular part of the gradient.
 893             call sc_grad
 894             endif
 895           enddo      ! j
 896         enddo        ! iint
 897       enddo          ! i
 898       return
 899       end
 900 C-----------------------------------------------------------------------------
 901       subroutine egbv(evdw,evdw_t)
 902 C
 903 C This subroutine calculates the interaction energy of nonbonded side chains
 904 C assuming the Gay-Berne-Vorobjev potential of interaction.
 905 C
 906       implicit real*8 (a-h,o-z)
 907       include 'DIMENSIONS'
 908       include 'DIMENSIONS.ZSCOPT'
 909       include "DIMENSIONS.COMPAR"
 910       include 'COMMON.GEO'
 911       include 'COMMON.VAR'
 912       include 'COMMON.LOCAL'
 913       include 'COMMON.CHAIN'
 914       include 'COMMON.DERIV'
 915       include 'COMMON.NAMES'
 916       include 'COMMON.INTERACT'
 917       include 'COMMON.ENEPS'
 918       include 'COMMON.IOUNITS'
 919       include 'COMMON.CALC'
 920       common /srutu/ icall
 921       logical lprn
 922       integer icant
 923       external icant
 924       do i=1,210
 925         do j=1,2
 926           eneps_temp(j,i)=0.0d0
 927         enddo
 928       enddo
 929       evdw=0.0D0
 930       evdw_t=0.0d0
 931 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 932       evdw=0.0D0
 933       lprn=.false.
 934 c      if (icall.gt.0) lprn=.true.
 935       ind=0
 936       do i=iatsc_s,iatsc_e
 937         itypi=itype(i)
 938         itypi1=itype(i+1)
 939         xi=c(1,nres+i)
 940         yi=c(2,nres+i)
 941         zi=c(3,nres+i)
 942         dxi=dc_norm(1,nres+i)
 943         dyi=dc_norm(2,nres+i)
 944         dzi=dc_norm(3,nres+i)
 945         dsci_inv=vbld_inv(i+nres)
 946 C
 947 C Calculate SC interaction energy.
 948 C
 949         do iint=1,nint_gr(i)
 950           do j=istart(i,iint),iend(i,iint)
 951             ind=ind+1
 952             itypj=itype(j)
 953             dscj_inv=vbld_inv(j+nres)
 954             sig0ij=sigma(itypi,itypj)
 955             r0ij=r0(itypi,itypj)
 956             chi1=chi(itypi,itypj)
 957             chi2=chi(itypj,itypi)
 958             chi12=chi1*chi2
 959             chip1=chip(itypi)
 960             chip2=chip(itypj)
 961             chip12=chip1*chip2
 962             alf1=alp(itypi)
 963             alf2=alp(itypj)
 964             alf12=0.5D0*(alf1+alf2)
 965 C For diagnostics only!!!
 966 c           chi1=0.0D0
 967 c           chi2=0.0D0
 968 c           chi12=0.0D0
 969 c           chip1=0.0D0
 970 c           chip2=0.0D0
 971 c           chip12=0.0D0
 972 c           alf1=0.0D0
 973 c           alf2=0.0D0
 974 c           alf12=0.0D0
 975             xj=c(1,nres+j)-xi
 976             yj=c(2,nres+j)-yi
 977             zj=c(3,nres+j)-zi
 978             dxj=dc_norm(1,nres+j)
 979             dyj=dc_norm(2,nres+j)
 980             dzj=dc_norm(3,nres+j)
 981             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 982             rij=dsqrt(rrij)
 983 C Calculate angle-dependent terms of energy and contributions to their
 984 C derivatives.
 985             call sc_angular
 986             sigsq=1.0D0/sigsq
 987             sig=sig0ij*dsqrt(sigsq)
 988             rij_shift=1.0D0/rij-sig+r0ij
 989 C I hate to put IF's in the loops, but here don't have another choice!!!!
 990             if (rij_shift.le.0.0D0) then
 991               evdw=1.0D20
 992               return
 993             endif
 994             sigder=-sig*sigsq
 995 c---------------------------------------------------------------
 996             rij_shift=1.0D0/rij_shift
 997             fac=rij_shift**expon
 998             e1=fac*fac*aa(itypi,itypj)
 999             e2=fac*bb(itypi,itypj)
1000             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1001             eps2der=evdwij*eps3rt
1002             eps3der=evdwij*eps2rt
1003             fac_augm=rrij**expon
1004             e_augm=augm(itypi,itypj)*fac_augm
1005             evdwij=evdwij*eps2rt*eps3rt
1006             if (bb(itypi,itypj).gt.0.0d0) then
1007               evdw=evdw+evdwij+e_augm
1008             else
1009               evdw_t=evdw_t+evdwij+e_augm
1010             endif
1011             ij=icant(itypi,itypj)
1012             aux=eps1*eps2rt**2*eps3rt**2
1013             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1014      &        /dabs(eps(itypi,itypj))
1015             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1016 c            eneps_temp(ij)=eneps_temp(ij)
1017 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1018 c            if (lprn) then
1019 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1020 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1021 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1022 c     &        restyp(itypi),i,restyp(itypj),j,
1023 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1024 c     &        chi1,chi2,chip1,chip2,
1025 c     &        eps1,eps2rt**2,eps3rt**2,
1026 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1027 c     &        evdwij+e_augm
1028 c            endif
1029             if (calc_grad) then
1030 C Calculate gradient components.
1031             e1=e1*eps1*eps2rt**2*eps3rt**2
1032             fac=-expon*(e1+evdwij)*rij_shift
1033             sigder=fac*sigder
1034             fac=rij*fac-2*expon*rrij*e_augm
1035 C Calculate the radial part of the gradient
1036             gg(1)=xj*fac
1037             gg(2)=yj*fac
1038             gg(3)=zj*fac
1039 C Calculate angular part of the gradient.
1040             call sc_grad
1041             endif
1042           enddo      ! j
1043         enddo        ! iint
1044       enddo          ! i
1045       return
1046       end
1047 C-----------------------------------------------------------------------------
1048
1049
1050       SUBROUTINE emomo(evdw,evdw_p,evdw_m)
1051 C
1052 C This subroutine calculates the interaction energy of nonbonded side chains
1053 C assuming the Gay-Berne potential of interaction.
1054 C
1055        IMPLICIT NONE
1056        INCLUDE 'DIMENSIONS'
1057        INCLUDE 'DIMENSIONS.ZSCOPT'
1058        INCLUDE 'COMMON.CALC'
1059        INCLUDE 'COMMON.CONTROL'
1060        INCLUDE 'COMMON.CHAIN'
1061        INCLUDE 'COMMON.DERIV'
1062        INCLUDE 'COMMON.EMP'
1063        INCLUDE 'COMMON.GEO'
1064        INCLUDE 'COMMON.INTERACT'
1065        INCLUDE 'COMMON.IOUNITS'
1066        INCLUDE 'COMMON.LOCAL'
1067        INCLUDE 'COMMON.NAMES'
1068        INCLUDE 'COMMON.VAR'
1069        logical lprn
1070        double precision scalar
1071        double precision ener(4)
1072        integer troll,iint
1073
1074        IF (energy_dec) write (iout,'(a)')
1075      & ' AAi i  AAj  j  1/rij  Rtail   Rhead   evdwij   Fcav   Ecl
1076      & Egb   Epol   Fisocav   Elj   Equad   evdw'
1077        evdw   = 0.0D0
1078        evdw_p = 0.0D0
1079        evdw_m = 0.0D0
1080 c DIAGNOSTICS
1081 ccccc      energy_dec=.false.
1082 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1083 c      lprn   = .false.
1084 c     if (icall.eq.0) lprn=.false.
1085 c END DIAGNOSTICS
1086 c      ind = 0
1087        DO i = iatsc_s, iatsc_e
1088         itypi  = itype(i)
1089 c        itypi1 = itype(i+1)
1090         dxi    = dc_norm(1,nres+i)
1091         dyi    = dc_norm(2,nres+i)
1092         dzi    = dc_norm(3,nres+i)
1093 c        dsci_inv=dsc_inv(itypi)
1094         dsci_inv = vbld_inv(i+nres)
1095 c        DO k = 1, 3
1096 c         ctail(k,1) = c(k, i+nres)
1097 c     &              - dtail(1,itypi,itypj) * dc_norm(k, nres+i)
1098 c        END DO
1099         xi=c(1,nres+i)
1100         yi=c(2,nres+i)
1101         zi=c(3,nres+i)
1102 c!-------------------------------------------------------------------
1103 C Calculate SC interaction energy.
1104         DO iint = 1, nint_gr(i)
1105          DO j = istart(i,iint), iend(i,iint)
1106 c! initialize variables for electrostatic gradients
1107           CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
1108 c            ind=ind+1
1109 c            dscj_inv = dsc_inv(itypj)
1110           dscj_inv = vbld_inv(j+nres)
1111 c! rij holds 1/(distance of Calpha atoms)
1112           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
1113           rij  = dsqrt(rrij)
1114 c!-------------------------------------------------------------------
1115 C Calculate angle-dependent terms of energy and contributions to their
1116 C derivatives.
1117
1118 #IFDEF CHECK_MOMO
1119 c!      DO troll = 10, 5000
1120 c!      om1    = 0.0d0
1121 c!      om2    = 0.0d0
1122 c!      om12   = 1.0d0
1123 c!      sqom1  = om1 * om1
1124 c!      sqom2  = om2 * om2
1125 c!      sqom12 = om12 * om12
1126 c!      rij    = 5.0d0 / troll
1127 c!      rrij   = rij * rij
1128 c!      Rtail  = troll / 5.0d0
1129 c!      Rhead  = troll / 5.0d0
1130 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1131 c!      Rtail = dsqrt((Rtail**2)
1132 c!     &      +((dabs(dtail(1,itypi,itypj)-dtail(2,itypi,itypj)))**2))
1133 c!      rij = 1.0d0/Rtail
1134 c!      rrij = rij * rij
1135 #ENDIF
1136           CALL sc_angular
1137 c! this should be in elgrad_init but om's are calculated by sc_angular
1138 c! which in turn is used by older potentials
1139 c! which proves how tangled UNRES code is >.<
1140 c! om = omega, sqom = om^2
1141           sqom1  = om1 * om1
1142           sqom2  = om2 * om2
1143           sqom12 = om12 * om12
1144
1145 c! now we calculate EGB - Gey-Berne
1146 c! It will be summed up in evdwij and saved in evdw
1147           sigsq     = 1.0D0  / sigsq
1148           sig       = sig0ij * dsqrt(sigsq)
1149 c!          rij_shift = 1.0D0  / rij - sig + sig0ij
1150           rij_shift = Rtail - sig + sig0ij
1151 c          write (2,*) "Rtal",Rtail," sig",sig," sigsq",sigsq,
1152 c     &       " sig0ij",sig0ij
1153 c          write (2,*) "rij_shift",rij_shift
1154           IF (rij_shift.le.0.0D0) THEN
1155            evdw = 1.0D20
1156            RETURN
1157           END IF
1158           sigder = -sig * sigsq
1159           rij_shift = 1.0D0 / rij_shift
1160           fac       = rij_shift**expon
1161           c1        = fac  * fac * aa(itypi,itypj)
1162 #ifdef SCALREP
1163 ! Scale down the repulsive term for 1,4 interactions.
1164           if (iabs(j-i).le.4) c1  = 0.01d0 * c1
1165 #endif
1166 c!          c1        = 0.0d0
1167           c2        = fac  * bb(itypi,itypj)
1168 c!          c2        = 0.0d0
1169 c          write (2,*) "eps1",eps1," eps2rt",eps2rt," eps3rt",eps3rt,
1170 c     &     " c1",c1," c2",c2
1171           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
1172           eps2der   = eps3rt * evdwij
1173           eps3der   = eps2rt * evdwij
1174 c!          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
1175           evdwij    = eps2rt * eps3rt * evdwij
1176 c!      evdwij = 0.0d0
1177 c!      write (*,*) "Gey Berne = ", evdwij
1178 #ifdef TSCSC
1179           IF (bb(itypi,itypj).gt.0) THEN
1180            evdw_p = evdw_p + evdwij
1181           ELSE
1182            evdw_m = evdw_m + evdwij
1183           END IF
1184 #else
1185           evdw = evdw
1186      &         + evdwij
1187 #endif
1188 c!-------------------------------------------------------------------
1189 c! Calculate some components of GGB
1190           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
1191           fac    = -expon * (c1 + evdwij) * rij_shift
1192           sigder = fac * sigder
1193 c!          fac    = rij * fac
1194 c! Calculate distance derivative
1195 c!          gg(1) = xj * fac
1196 c!          gg(2) = yj * fac
1197 c!          gg(3) = zj * fac
1198           gg(1) = fac
1199           gg(2) = fac
1200           gg(3) = fac
1201 c!      write (*,*) "gg(1) = ", gg(1)
1202 c!      write (*,*) "gg(2) = ", gg(2)
1203 c!      write (*,*) "gg(3) = ", gg(3)
1204 c! The angular derivatives of GGB are brought together in sc_grad
1205 c!-------------------------------------------------------------------
1206 c! Fcav
1207 c!
1208 c! Catch gly-gly interactions to skip calculation of something that
1209 c! does not exist
1210
1211       IF (itypi.eq.10.and.itypj.eq.10) THEN
1212        Fcav = 0.0d0
1213        dFdR = 0.0d0
1214        dCAVdOM1  = 0.0d0
1215        dCAVdOM2  = 0.0d0
1216        dCAVdOM12 = 0.0d0
1217       ELSE
1218
1219 c! we are not 2 glycines, so we calculate Fcav (and maybe more)
1220        fac = chis1 * sqom1 + chis2 * sqom2
1221      &     - 2.0d0 * chis12 * om1 * om2 * om12
1222 c! we will use pom later in Gcav, so dont mess with it!
1223        pom = 1.0d0 - chis1 * chis2 * sqom12
1224
1225        Lambf = (1.0d0 - (fac / pom))
1226        Lambf = dsqrt(Lambf)
1227
1228
1229        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
1230 c!       write (*,*) "sparrow = ", sparrow
1231        Chif = Rtail * sparrow
1232        ChiLambf = Chif * Lambf
1233        eagle = dsqrt(ChiLambf)
1234        bat = ChiLambf ** 11.0d0
1235
1236        top = b1 * ( eagle + b2 * ChiLambf - b3 )
1237        bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
1238        botsq = bot * bot
1239
1240 c!      write (*,*) "sig1 = ",sig1
1241 c!      write (*,*) "sig2 = ",sig2
1242 c!      write (*,*) "Rtail = ",Rtail
1243 c!      write (*,*) "sparrow = ",sparrow
1244 c!      write (*,*) "Chis1 = ", chis1
1245 c!      write (*,*) "Chis2 = ", chis2
1246 c!      write (*,*) "Chis12 = ", chis12
1247 c!      write (*,*) "om1 = ", om1
1248 c!      write (*,*) "om2 = ", om2
1249 c!      write (*,*) "om12 = ", om12
1250 c!      write (*,*) "sqom1 = ", sqom1
1251 c!      write (*,*) "sqom2 = ", sqom2
1252 c!      write (*,*) "sqom12 = ", sqom12
1253 c!      write (*,*) "Lambf = ",Lambf
1254 c!      write (*,*) "b1 = ",b1
1255 c!      write (*,*) "b2 = ",b2
1256 c!      write (*,*) "b3 = ",b3
1257 c!      write (*,*) "b4 = ",b4
1258 c!      write (*,*) "top = ",top
1259 c!      write (*,*) "bot = ",bot
1260        Fcav = top / bot
1261 c!       Fcav = 0.0d0
1262 c!      write (*,*) "Fcav = ", Fcav
1263 c!-------------------------------------------------------------------
1264 c! derivative of Fcav is Gcav...
1265 c!---------------------------------------------------
1266
1267        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
1268        dbot = 12.0d0 * b4 * bat * Lambf
1269        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
1270 c!       dFdR = 0.0d0
1271 c!      write (*,*) "dFcav/dR = ", dFdR
1272
1273        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
1274        dbot = 12.0d0 * b4 * bat * Chif
1275        eagle = Lambf * pom
1276        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
1277        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
1278        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)
1279      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)
1280
1281        dFdL = ((dtop * bot - top * dbot) / botsq)
1282 c!       dFdL = 0.0d0
1283        dCAVdOM1  = dFdL * ( dFdOM1 )
1284        dCAVdOM2  = dFdL * ( dFdOM2 )
1285        dCAVdOM12 = dFdL * ( dFdOM12 )
1286 c!      write (*,*) "dFcav/dOM1 = ", dCAVdOM1
1287 c!      write (*,*) "dFcav/dOM2 = ", dCAVdOM2
1288 c!      write (*,*) "dFcav/dOM12 = ", dCAVdOM12
1289 c!      write (*,*) ""
1290 c!-------------------------------------------------------------------
1291 c! Finally, add the distance derivatives of GB and Fcav to gvdwc
1292 c! Pom is used here to project the gradient vector into
1293 c! cartesian coordinates and at the same time contains
1294 c! dXhb/dXsc derivative (for charged amino acids
1295 c! location of hydrophobic centre of interaction is not
1296 c! the same as geometric centre of side chain, this
1297 c! derivative takes that into account)
1298 c! derivatives of omega angles will be added in sc_grad
1299
1300        DO k= 1, 3
1301         ertail(k) = Rtail_distance(k)/Rtail
1302        END DO
1303        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
1304        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
1305        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1306        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1307        DO k = 1, 3
1308 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1309 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1310         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
1311         gvdwx(k,i) = gvdwx(k,i)
1312      &             - (( dFdR + gg(k) ) * pom)
1313 c!     &             - ( dFdR * pom )
1314         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
1315         gvdwx(k,j) = gvdwx(k,j)
1316      &             + (( dFdR + gg(k) ) * pom)
1317 c!     &             + ( dFdR * pom )
1318
1319         gvdwc(k,i) = gvdwc(k,i)
1320      &             - (( dFdR + gg(k) ) * ertail(k))
1321 c!     &             - ( dFdR * ertail(k))
1322
1323         gvdwc(k,j) = gvdwc(k,j)
1324      &             + (( dFdR + gg(k) ) * ertail(k))
1325 c!     &             + ( dFdR * ertail(k))
1326
1327         gg(k) = 0.0d0
1328 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1329 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1330       END DO
1331
1332 c!-------------------------------------------------------------------
1333 c! Compute head-head and head-tail energies for each state
1334
1335           isel = iabs(Qi) + iabs(Qj)
1336           IF (isel.eq.0) THEN
1337 c! No charges - do nothing
1338            eheadtail = 0.0d0
1339
1340           ELSE IF (isel.eq.4) THEN
1341 c! Calculate dipole-dipole interactions
1342            CALL edd(ecl)
1343            eheadtail = ECL
1344
1345           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
1346 c! Charge-nonpolar interactions
1347            CALL eqn(epol)
1348            eheadtail = epol
1349
1350           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
1351 c! Nonpolar-charge interactions
1352            CALL enq(epol)
1353            eheadtail = epol
1354
1355           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
1356 c! Charge-dipole interactions
1357            CALL eqd(ecl, elj, epol)
1358            eheadtail = ECL + elj + epol
1359
1360           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
1361 c! Dipole-charge interactions
1362            CALL edq(ecl, elj, epol)
1363            eheadtail = ECL + elj + epol
1364
1365           ELSE IF ((isel.eq.2.and.
1366      &          iabs(Qi).eq.1).and.
1367      &          nstate(itypi,itypj).eq.1) THEN
1368 c! Same charge-charge interaction ( +/+ or -/- )
1369            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
1370            eheadtail = ECL + Egb + Epol + Fisocav + Elj
1371
1372           ELSE IF ((isel.eq.2.and.
1373      &          iabs(Qi).eq.1).and.
1374      &          nstate(itypi,itypj).ne.1) THEN
1375 c! Different charge-charge interaction ( +/- or -/+ )
1376            CALL energy_quad
1377      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1378           END IF
1379        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
1380 c!      write (*,*) "evdw = ", evdw
1381 c!      write (*,*) "Fcav = ", Fcav
1382 c!      write (*,*) "eheadtail = ", eheadtail
1383        evdw = evdw
1384      &      + Fcav
1385      &      + eheadtail
1386
1387        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)')
1388      &  restyp(itype(i)),i,restyp(itype(j)),j,
1389      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1390      &  Equad,evdwij+Fcav+eheadtail,evdw
1391 c       IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
1392 c     &  restyp(itype(i)),i,restyp(itype(j)),j,
1393 c     &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1394 c     &  Equad,evdwij+Fcav+eheadtail,evdw
1395 #IFDEF CHECK_MOMO
1396        evdw = 0.0d0
1397        END DO ! troll
1398 #ENDIF
1399
1400 c!-------------------------------------------------------------------
1401 c! As all angular derivatives are done, now we sum them up,
1402 c! then transform and project into cartesian vectors and add to gvdwc
1403 c! We call sc_grad always, with the exception of +/- interaction.
1404 c! This is because energy_quad subroutine needs to handle
1405 c! this job in his own way.
1406 c! This IS probably not very efficient and SHOULD be optimised
1407 c! but it will require major restructurization of emomo
1408 c! so it will be left as it is for now
1409 c!       write (*,*) 'troll1, nstate =', nstate (itypi,itypj)
1410        IF (nstate(itypi,itypj).eq.1) THEN
1411 #ifdef TSCSC
1412         IF (bb(itypi,itypj).gt.0) THEN
1413          CALL sc_grad
1414         ELSE
1415          CALL sc_grad_T
1416         END IF
1417 #else
1418         CALL sc_grad
1419 #endif
1420        END IF
1421 c!-------------------------------------------------------------------
1422 c! NAPISY KONCOWE
1423          END DO   ! j
1424         END DO    ! iint
1425        END DO     ! i
1426        if (energy_dec) write (iout,*) "evdw before exiting emomo:",evdw
1427 c      write (iout,*) "Number of loop steps in EGB:",ind
1428 c      energy_dec=.false.
1429        RETURN
1430       END SUBROUTINE emomo
1431 c! END OF MOMO
1432
1433
1434 C-----------------------------------------------------------------------------
1435
1436
1437       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
1438        IMPLICIT NONE
1439        INCLUDE 'DIMENSIONS'
1440        INCLUDE 'DIMENSIONS.ZSCOPT'
1441        INCLUDE 'COMMON.CALC'
1442        INCLUDE 'COMMON.CHAIN'
1443        INCLUDE 'COMMON.CONTROL'
1444        INCLUDE 'COMMON.DERIV'
1445        INCLUDE 'COMMON.EMP'
1446        INCLUDE 'COMMON.GEO'
1447        INCLUDE 'COMMON.INTERACT'
1448        INCLUDE 'COMMON.IOUNITS'
1449        INCLUDE 'COMMON.LOCAL'
1450        INCLUDE 'COMMON.NAMES'
1451        INCLUDE 'COMMON.VAR'
1452        double precision scalar, facd3, facd4, federmaus, adler
1453 c! Epol and Gpol analytical parameters
1454        alphapol1 = alphapol(itypi,itypj)
1455        alphapol2 = alphapol(itypj,itypi)
1456 c! Fisocav and Gisocav analytical parameters
1457        al1  = alphiso(1,itypi,itypj)
1458        al2  = alphiso(2,itypi,itypj)
1459        al3  = alphiso(3,itypi,itypj)
1460        al4  = alphiso(4,itypi,itypj)
1461        csig = (1.0d0
1462      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1463      &      + sigiso2(itypi,itypj)**2.0d0))
1464 c!
1465        pis  = sig0head(itypi,itypj)
1466        eps_head = epshead(itypi,itypj)
1467        Rhead_sq = Rhead * Rhead
1468 c! R1 - distance between head of ith side chain and tail of jth sidechain
1469 c! R2 - distance between head of jth side chain and tail of ith sidechain
1470        R1 = 0.0d0
1471        R2 = 0.0d0
1472        DO k = 1, 3
1473 c! Calculate head-to-tail distances needed by Epol
1474         R1=R1+(ctail(k,2)-chead(k,1))**2
1475         R2=R2+(chead(k,2)-ctail(k,1))**2
1476        END DO
1477 c! Pitagoras
1478        R1 = dsqrt(R1)
1479        R2 = dsqrt(R2)
1480
1481 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1482 c!     &        +dhead(1,1,itypi,itypj))**2))
1483 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1484 c!     &        +dhead(2,1,itypi,itypj))**2))
1485
1486 c!-------------------------------------------------------------------
1487 c! Coulomb electrostatic interaction
1488        Ecl = (332.0d0 * Qij) / Rhead
1489 c! derivative of Ecl is Gcl...
1490        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
1491        dGCLdOM1 = 0.0d0
1492        dGCLdOM2 = 0.0d0
1493        dGCLdOM12 = 0.0d0
1494 c!-------------------------------------------------------------------
1495 c! Generalised Born Solvent Polarization
1496 c! Charged head polarizes the solvent
1497        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1498        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1499        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1500 c! Derivative of Egb is Ggb...
1501        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1502        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1503      &        / ( 2.0d0 * Fgb )
1504        dGGBdR = dGGBdFGB * dFGBdR
1505 c!-------------------------------------------------------------------
1506 c! Fisocav - isotropic cavity creation term
1507 c! or "how much energy it costs to put charged head in water"
1508        pom = Rhead * csig
1509        top = al1 * (dsqrt(pom) + al2 * pom - al3)
1510        bot = (1.0d0 + al4 * pom**12.0d0)
1511        botsq = bot * bot
1512        FisoCav = top / bot
1513 c!      write (*,*) "Rhead = ",Rhead
1514 c!      write (*,*) "csig = ",csig
1515 c!      write (*,*) "pom = ",pom
1516 c!      write (*,*) "al1 = ",al1
1517 c!      write (*,*) "al2 = ",al2
1518 c!      write (*,*) "al3 = ",al3
1519 c!      write (*,*) "al4 = ",al4
1520 c!      write (*,*) "top = ",top
1521 c!      write (*,*) "bot = ",bot
1522 c! Derivative of Fisocav is GCV...
1523        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1524        dbot = 12.0d0 * al4 * pom ** 11.0d0
1525        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1526 c!-------------------------------------------------------------------
1527 c! Epol
1528 c! Polarization energy - charged heads polarize hydrophobic "neck"
1529        MomoFac1 = (1.0d0 - chi1 * sqom2)
1530        MomoFac2 = (1.0d0 - chi2 * sqom1)
1531        RR1  = ( R1 * R1 ) / MomoFac1
1532        RR2  = ( R2 * R2 ) / MomoFac2
1533        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1534        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1535        fgb1 = sqrt( RR1 + a12sq * ee1 )
1536        fgb2 = sqrt( RR2 + a12sq * ee2 )
1537        epol = 332.0d0 * eps_inout_fac * (
1538      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1539 c!       epol = 0.0d0
1540 c       write (*,*) "eps_inout_fac = ",eps_inout_fac
1541 c       write (*,*) "alphapol1 = ", alphapol1
1542 c       write (*,*) "alphapol2 = ", alphapol2
1543 c       write (*,*) "fgb1 = ", fgb1
1544 c       write (*,*) "fgb2 = ", fgb2
1545 c       write (*,*) "epol = ", epol
1546 c! derivative of Epol is Gpol...
1547        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1548      &          / (fgb1 ** 5.0d0)
1549        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1550      &          / (fgb2 ** 5.0d0)
1551        dFGBdR1 = ( (R1 / MomoFac1)
1552      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
1553      &        / ( 2.0d0 * fgb1 )
1554        dFGBdR2 = ( (R2 / MomoFac2)
1555      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
1556      &        / ( 2.0d0 * fgb2 )
1557        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1558      &          * ( 2.0d0 - 0.5d0 * ee1) )
1559      &          / ( 2.0d0 * fgb1 )
1560        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1561      &          * ( 2.0d0 - 0.5d0 * ee2) )
1562      &          / ( 2.0d0 * fgb2 )
1563        dPOLdR1 = dPOLdFGB1 * dFGBdR1
1564 c!       dPOLdR1 = 0.0d0
1565        dPOLdR2 = dPOLdFGB2 * dFGBdR2
1566 c!       dPOLdR2 = 0.0d0
1567        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1568 c!       dPOLdOM1 = 0.0d0
1569        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1570 c!       dPOLdOM2 = 0.0d0
1571 c!-------------------------------------------------------------------
1572 c! Elj
1573 c! Lennard-Jones 6-12 interaction between heads
1574        pom = (pis / Rhead)**6.0d0
1575        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1576 c! derivative of Elj is Glj
1577        dGLJdR = 4.0d0 * eps_head
1578      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1579      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1580 c!-------------------------------------------------------------------
1581 c! Return the results
1582 c! These things do the dRdX derivatives, that is
1583 c! allow us to change what we see from function that changes with
1584 c! distance to function that changes with LOCATION (of the interaction
1585 c! site)
1586        DO k = 1, 3
1587         erhead(k) = Rhead_distance(k)/Rhead
1588         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1589         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1590        END DO
1591
1592        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1593        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1594        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1595        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1596        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1597        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1598        facd1 = d1 * vbld_inv(i+nres)
1599        facd2 = d2 * vbld_inv(j+nres)
1600        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1601        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1602
1603 c! Now we add appropriate partial derivatives (one in each dimension)
1604        DO k = 1, 3
1605         hawk   = (erhead_tail(k,1) +
1606      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
1607         condor = (erhead_tail(k,2) +
1608      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
1609
1610         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1611         gvdwx(k,i) = gvdwx(k,i)
1612      &             - dGCLdR * pom
1613      &             - dGGBdR * pom
1614      &             - dGCVdR * pom
1615      &             - dPOLdR1 * hawk
1616      &             - dPOLdR2 * (erhead_tail(k,2)
1617      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1618      &             - dGLJdR * pom
1619
1620         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1621         gvdwx(k,j) = gvdwx(k,j)
1622      &             + dGCLdR * pom
1623      &             + dGGBdR * pom
1624      &             + dGCVdR * pom
1625      &             + dPOLdR1 * (erhead_tail(k,1)
1626      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1627      &             + dPOLdR2 * condor
1628      &             + dGLJdR * pom
1629
1630         gvdwc(k,i) = gvdwc(k,i)
1631      &             - dGCLdR * erhead(k)
1632      &             - dGGBdR * erhead(k)
1633      &             - dGCVdR * erhead(k)
1634      &             - dPOLdR1 * erhead_tail(k,1)
1635      &             - dPOLdR2 * erhead_tail(k,2)
1636      &             - dGLJdR * erhead(k)
1637
1638         gvdwc(k,j) = gvdwc(k,j)
1639      &             + dGCLdR * erhead(k)
1640      &             + dGGBdR * erhead(k)
1641      &             + dGCVdR * erhead(k)
1642      &             + dPOLdR1 * erhead_tail(k,1)
1643      &             + dPOLdR2 * erhead_tail(k,2)
1644      &             + dGLJdR * erhead(k)
1645
1646        END DO
1647        RETURN
1648       END SUBROUTINE eqq
1649 c!-------------------------------------------------------------------
1650       SUBROUTINE energy_quad
1651      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1652        IMPLICIT NONE
1653        INCLUDE 'DIMENSIONS'
1654        INCLUDE 'DIMENSIONS.ZSCOPT'
1655        INCLUDE 'COMMON.CALC'
1656        INCLUDE 'COMMON.CHAIN'
1657        INCLUDE 'COMMON.CONTROL'
1658        INCLUDE 'COMMON.DERIV'
1659        INCLUDE 'COMMON.EMP'
1660        INCLUDE 'COMMON.GEO'
1661        INCLUDE 'COMMON.INTERACT'
1662        INCLUDE 'COMMON.IOUNITS'
1663        INCLUDE 'COMMON.LOCAL'
1664        INCLUDE 'COMMON.NAMES'
1665        INCLUDE 'COMMON.VAR'
1666        double precision scalar
1667        double precision ener(4)
1668        double precision dcosom1(3),dcosom2(3)
1669 c! used in Epol derivatives
1670        double precision facd3, facd4
1671        double precision federmaus, adler
1672 c! Epol and Gpol analytical parameters
1673        alphapol1 = alphapol(itypi,itypj)
1674        alphapol2 = alphapol(itypj,itypi)
1675 c! Fisocav and Gisocav analytical parameters
1676        al1  = alphiso(1,itypi,itypj)
1677        al2  = alphiso(2,itypi,itypj)
1678        al3  = alphiso(3,itypi,itypj)
1679        al4  = alphiso(4,itypi,itypj)
1680        csig = (1.0d0
1681      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1682      &      + sigiso2(itypi,itypj)**2.0d0))
1683 c!
1684        w1   = wqdip(1,itypi,itypj)
1685        w2   = wqdip(2,itypi,itypj)
1686        pis  = sig0head(itypi,itypj)
1687        eps_head = epshead(itypi,itypj)
1688 c! First things first:
1689 c! We need to do sc_grad's job with GB and Fcav
1690        eom1  =
1691      &         eps2der * eps2rt_om1
1692      &       - 2.0D0 * alf1 * eps3der
1693      &       + sigder * sigsq_om1
1694      &       + dCAVdOM1
1695        eom2  =
1696      &         eps2der * eps2rt_om2
1697      &       + 2.0D0 * alf2 * eps3der
1698      &       + sigder * sigsq_om2
1699      &       + dCAVdOM2
1700        eom12 =
1701      &         evdwij  * eps1_om12
1702      &       + eps2der * eps2rt_om12
1703      &       - 2.0D0 * alf12 * eps3der
1704      &       + sigder *sigsq_om12
1705      &       + dCAVdOM12
1706 c! now some magical transformations to project gradient into
1707 c! three cartesian vectors
1708        DO k = 1, 3
1709         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1710         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1711         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
1712 c! this acts on hydrophobic center of interaction
1713         gvdwx(k,i)= gvdwx(k,i) - gg(k)
1714      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1715      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1716         gvdwx(k,j)= gvdwx(k,j) + gg(k)
1717      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1718      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1719 c! this acts on Calpha
1720         gvdwc(k,i)=gvdwc(k,i)-gg(k)
1721         gvdwc(k,j)=gvdwc(k,j)+gg(k)
1722        END DO
1723 c! sc_grad is done, now we will compute
1724        eheadtail = 0.0d0
1725        eom1 = 0.0d0
1726        eom2 = 0.0d0
1727        eom12 = 0.0d0
1728
1729 c! ENERGY DEBUG
1730 c!       ii = 1
1731 c!       jj = 1
1732 c!       d1 = dhead(1, 1, itypi, itypj)
1733 c!       d2 = dhead(2, 1, itypi, itypj)
1734 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1735 c!     &        +dhead(1,ii,itypi,itypj))**2))
1736 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1737 c!     &        +dhead(2,jj,itypi,itypj))**2))
1738 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1739 c! END OF ENERGY DEBUG
1740 c*************************************************************
1741        DO istate = 1, nstate(itypi,itypj)
1742 c*************************************************************
1743         IF (istate.ne.1) THEN
1744          IF (istate.lt.3) THEN
1745           ii = 1
1746          ELSE
1747           ii = 2
1748          END IF
1749         jj = istate/ii
1750         d1 = dhead(1,ii,itypi,itypj)
1751         d2 = dhead(2,jj,itypi,itypj)
1752         DO k = 1,3
1753          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
1754          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
1755          Rhead_distance(k) = chead(k,2) - chead(k,1)
1756         END DO
1757 c! pitagoras (root of sum of squares)
1758         Rhead = dsqrt(
1759      &          (Rhead_distance(1)*Rhead_distance(1))
1760      &        + (Rhead_distance(2)*Rhead_distance(2))
1761      &        + (Rhead_distance(3)*Rhead_distance(3)))
1762         END IF
1763         Rhead_sq = Rhead * Rhead
1764
1765 c! R1 - distance between head of ith side chain and tail of jth sidechain
1766 c! R2 - distance between head of jth side chain and tail of ith sidechain
1767         R1 = 0.0d0
1768         R2 = 0.0d0
1769         DO k = 1, 3
1770 c! Calculate head-to-tail distances
1771          R1=R1+(ctail(k,2)-chead(k,1))**2
1772          R2=R2+(chead(k,2)-ctail(k,1))**2
1773         END DO
1774 c! Pitagoras
1775         R1 = dsqrt(R1)
1776         R2 = dsqrt(R2)
1777
1778 c! ENERGY DEBUG
1779 c!      write (*,*) "istate = ", istate
1780 c!      write (*,*) "ii = ", ii
1781 c!      write (*,*) "jj = ", jj
1782 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1783 c!     &        +dhead(1,ii,itypi,itypj))**2))
1784 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1785 c!     &        +dhead(2,jj,itypi,itypj))**2))
1786 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1787 c!      Rhead_sq = Rhead * Rhead
1788 c!      write (*,*) "d1 = ",d1
1789 c!      write (*,*) "d2 = ",d2
1790 c!      write (*,*) "R1 = ",R1
1791 c!      write (*,*) "R2 = ",R2
1792 c!      write (*,*) "Rhead = ",Rhead
1793 c! END OF ENERGY DEBUG
1794
1795 c!-------------------------------------------------------------------
1796 c! Coulomb electrostatic interaction
1797         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
1798 c!        Ecl = 0.0d0
1799 c!        write (*,*) "Ecl = ", Ecl
1800 c! derivative of Ecl is Gcl...
1801         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
1802 c!        dGCLdR = 0.0d0
1803         dGCLdOM1 = 0.0d0
1804         dGCLdOM2 = 0.0d0
1805         dGCLdOM12 = 0.0d0
1806 c!-------------------------------------------------------------------
1807 c! Generalised Born Solvent Polarization
1808         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1809         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1810         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1811 c!        Egb = 0.0d0
1812 c!      write (*,*) "a1*a2 = ", a12sq
1813 c!      write (*,*) "Rhead = ", Rhead
1814 c!      write (*,*) "Rhead_sq = ", Rhead_sq
1815 c!      write (*,*) "ee = ", ee
1816 c!      write (*,*) "Fgb = ", Fgb
1817 c!      write (*,*) "fac = ", eps_inout_fac
1818 c!      write (*,*) "Qij = ", Qij
1819 c!      write (*,*) "Egb = ", Egb
1820 c! Derivative of Egb is Ggb...
1821 c! dFGBdR is used by Quad's later...
1822         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1823         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1824      &         / ( 2.0d0 * Fgb )
1825         dGGBdR = dGGBdFGB * dFGBdR
1826 c!        dGGBdR = 0.0d0
1827 c!-------------------------------------------------------------------
1828 c! Fisocav - isotropic cavity creation term
1829         pom = Rhead * csig
1830         top = al1 * (dsqrt(pom) + al2 * pom - al3)
1831         bot = (1.0d0 + al4 * pom**12.0d0)
1832         botsq = bot * bot
1833         FisoCav = top / bot
1834 c!        FisoCav = 0.0d0
1835 c!      write (*,*) "pom = ",pom
1836 c!      write (*,*) "al1 = ",al1
1837 c!      write (*,*) "al2 = ",al2
1838 c!      write (*,*) "al3 = ",al3
1839 c!      write (*,*) "al4 = ",al4
1840 c!      write (*,*) "top = ",top
1841 c!      write (*,*) "bot = ",bot
1842 c!      write (*,*) "Fisocav = ", Fisocav
1843
1844 c! Derivative of Fisocav is GCV...
1845         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1846         dbot = 12.0d0 * al4 * pom ** 11.0d0
1847         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1848 c!        dGCVdR = 0.0d0
1849 c!-------------------------------------------------------------------
1850 c! Polarization energy
1851 c! Epol
1852         MomoFac1 = (1.0d0 - chi1 * sqom2)
1853         MomoFac2 = (1.0d0 - chi2 * sqom1)
1854         RR1  = ( R1 * R1 ) / MomoFac1
1855         RR2  = ( R2 * R2 ) / MomoFac2
1856         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1857         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1858         fgb1 = sqrt( RR1 + a12sq * ee1 )
1859         fgb2 = sqrt( RR2 + a12sq * ee2 )
1860         epol = 332.0d0 * eps_inout_fac * (
1861      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1862 c!        epol = 0.0d0
1863 c! derivative of Epol is Gpol...
1864         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1865      &            / (fgb1 ** 5.0d0)
1866         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1867      &            / (fgb2 ** 5.0d0)
1868         dFGBdR1 = ( (R1 / MomoFac1)
1869      &          * ( 2.0d0 - (0.5d0 * ee1) ) )
1870      &          / ( 2.0d0 * fgb1 )
1871         dFGBdR2 = ( (R2 / MomoFac2)
1872      &          * ( 2.0d0 - (0.5d0 * ee2) ) )
1873      &          / ( 2.0d0 * fgb2 )
1874         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1875      &           * ( 2.0d0 - 0.5d0 * ee1) )
1876      &           / ( 2.0d0 * fgb1 )
1877         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1878      &           * ( 2.0d0 - 0.5d0 * ee2) )
1879      &           / ( 2.0d0 * fgb2 )
1880         dPOLdR1 = dPOLdFGB1 * dFGBdR1
1881 c!        dPOLdR1 = 0.0d0
1882         dPOLdR2 = dPOLdFGB2 * dFGBdR2
1883 c!        dPOLdR2 = 0.0d0
1884         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1885 c!        dPOLdOM1 = 0.0d0
1886         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1887 c!        dPOLdOM2 = 0.0d0
1888 c!-------------------------------------------------------------------
1889 c! Elj
1890         pom = (pis / Rhead)**6.0d0
1891         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1892 c!        Elj = 0.0d0
1893 c! derivative of Elj is Glj
1894         dGLJdR = 4.0d0 * eps_head
1895      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1896      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1897 c!        dGLJdR = 0.0d0
1898 c!-------------------------------------------------------------------
1899 c! Equad
1900        IF (Wqd.ne.0.0d0) THEN
1901         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)
1902      &        - 37.5d0  * ( sqom1 + sqom2 )
1903      &        + 157.5d0 * ( sqom1 * sqom2 )
1904      &        - 45.0d0  * om1*om2*om12
1905         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
1906         Equad = fac * Beta1
1907 c!        Equad = 0.0d0
1908 c! derivative of Equad...
1909         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
1910 c!        dQUADdR = 0.0d0
1911         dQUADdOM1 = fac
1912      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
1913 c!        dQUADdOM1 = 0.0d0
1914         dQUADdOM2 = fac
1915      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
1916 c!        dQUADdOM2 = 0.0d0
1917         dQUADdOM12 = fac
1918      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )
1919 c!        dQUADdOM12 = 0.0d0
1920         ELSE
1921          Beta1 = 0.0d0
1922          Equad = 0.0d0
1923         END IF
1924 c!-------------------------------------------------------------------
1925 c! Return the results
1926 c! Angular stuff
1927         eom1 = dPOLdOM1 + dQUADdOM1
1928         eom2 = dPOLdOM2 + dQUADdOM2
1929         eom12 = dQUADdOM12
1930 c! now some magical transformations to project gradient into
1931 c! three cartesian vectors
1932         DO k = 1, 3
1933          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1934          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1935          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
1936         END DO
1937 c! Radial stuff
1938         DO k = 1, 3
1939          erhead(k) = Rhead_distance(k)/Rhead
1940          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1941          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1942         END DO
1943         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1944         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1945         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1946         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1947         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1948         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1949         facd1 = d1 * vbld_inv(i+nres)
1950         facd2 = d2 * vbld_inv(j+nres)
1951         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1952         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1953 c! Throw the results into gheadtail which holds gradients
1954 c! for each micro-state
1955         DO k = 1, 3
1956          hawk   = erhead_tail(k,1) +
1957      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
1958          condor = erhead_tail(k,2) +
1959      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
1960
1961          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1962 c! this acts on hydrophobic center of interaction
1963          gheadtail(k,1,1) = gheadtail(k,1,1)
1964      &                    - dGCLdR * pom
1965      &                    - dGGBdR * pom
1966      &                    - dGCVdR * pom
1967      &                    - dPOLdR1 * hawk
1968      &                    - dPOLdR2 * (erhead_tail(k,2)
1969      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1970      &                    - dGLJdR * pom
1971      &                    - dQUADdR * pom
1972      &                    - tuna(k)
1973      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1974      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1975
1976          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1977 c! this acts on hydrophobic center of interaction
1978          gheadtail(k,2,1) = gheadtail(k,2,1)
1979      &                    + dGCLdR * pom
1980      &                    + dGGBdR * pom
1981      &                    + dGCVdR * pom
1982      &                    + dPOLdR1 * (erhead_tail(k,1)
1983      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1984      &                    + dPOLdR2 * condor
1985      &                    + dGLJdR * pom
1986      &                    + dQUADdR * pom
1987      &                    + tuna(k)
1988      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1989      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1990
1991 c! this acts on Calpha
1992          gheadtail(k,3,1) = gheadtail(k,3,1)
1993      &                    - dGCLdR * erhead(k)
1994      &                    - dGGBdR * erhead(k)
1995      &                    - dGCVdR * erhead(k)
1996      &                    - dPOLdR1 * erhead_tail(k,1)
1997      &                    - dPOLdR2 * erhead_tail(k,2)
1998      &                    - dGLJdR * erhead(k)
1999      &                    - dQUADdR * erhead(k)
2000      &                    - tuna(k)
2001
2002 c! this acts on Calpha
2003          gheadtail(k,4,1) = gheadtail(k,4,1)
2004      &                    + dGCLdR * erhead(k)
2005      &                    + dGGBdR * erhead(k)
2006      &                    + dGCVdR * erhead(k)
2007      &                    + dPOLdR1 * erhead_tail(k,1)
2008      &                    + dPOLdR2 * erhead_tail(k,2)
2009      &                    + dGLJdR * erhead(k)
2010      &                    + dQUADdR * erhead(k)
2011      &                    + tuna(k)
2012         END DO
2013 c!      write(*,*) "ECL = ", Ecl
2014 c!      write(*,*) "Egb = ", Egb
2015 c!      write(*,*) "Epol = ", Epol
2016 c!      write(*,*) "Fisocav = ", Fisocav
2017 c!      write(*,*) "Elj = ", Elj
2018 c!      write(*,*) "Equad = ", Equad
2019 c!      write(*,*) "wstate = ", wstate(istate,itypi,itypj)
2020 c!      write(*,*) "eheadtail = ", eheadtail
2021 c!      write(*,*) "TROLL = ", dexp(-betaT * ener(istate))
2022 c!      write(*,*) "dGCLdR = ", dGCLdR
2023 c!      write(*,*) "dGGBdR = ", dGGBdR
2024 c!      write(*,*) "dGCVdR = ", dGCVdR
2025 c!      write(*,*) "dPOLdR1 = ", dPOLdR1
2026 c!      write(*,*) "dPOLdR2 = ", dPOLdR2
2027 c!      write(*,*) "dGLJdR = ", dGLJdR
2028 c!      write(*,*) "dQUADdR = ", dQUADdR
2029 c!      write(*,*) "tuna(",k,") = ", tuna(k)
2030         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
2031         eheadtail = eheadtail
2032      &            + wstate(istate, itypi, itypj)
2033      &            * dexp(-betaT * ener(istate))
2034 c! foreach cartesian dimension
2035         DO k = 1, 3
2036 c! foreach of two gvdwx and gvdwc
2037          DO l = 1, 4
2038           gheadtail(k,l,2) = gheadtail(k,l,2)
2039      &                     + wstate( istate, itypi, itypj )
2040      &                     * dexp(-betaT * ener(istate))
2041      &                     * gheadtail(k,l,1)
2042           gheadtail(k,l,1) = 0.0d0
2043          END DO
2044         END DO
2045        END DO
2046 c! Here ended the gigantic DO istate = 1, 4, which starts
2047 c! at the beggining of the subroutine
2048
2049        DO k = 1, 3
2050         DO l = 1, 4
2051          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
2052         END DO
2053         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
2054         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
2055         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
2056         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
2057         DO l = 1, 4
2058          gheadtail(k,l,1) = 0.0d0
2059          gheadtail(k,l,2) = 0.0d0
2060         END DO
2061        END DO
2062        eheadtail = (-dlog(eheadtail)) / betaT
2063        dPOLdOM1 = 0.0d0
2064        dPOLdOM2 = 0.0d0
2065        dQUADdOM1 = 0.0d0
2066        dQUADdOM2 = 0.0d0
2067        dQUADdOM12 = 0.0d0
2068        RETURN
2069       END SUBROUTINE energy_quad
2070
2071
2072 c!-------------------------------------------------------------------
2073
2074
2075       SUBROUTINE eqn(Epol)
2076       IMPLICIT NONE
2077       INCLUDE 'DIMENSIONS'
2078       INCLUDE 'DIMENSIONS.ZSCOPT'
2079       INCLUDE 'COMMON.CALC'
2080       INCLUDE 'COMMON.CHAIN'
2081       INCLUDE 'COMMON.CONTROL'
2082       INCLUDE 'COMMON.DERIV'
2083       INCLUDE 'COMMON.EMP'
2084       INCLUDE 'COMMON.GEO'
2085       INCLUDE 'COMMON.INTERACT'
2086       INCLUDE 'COMMON.IOUNITS'
2087       INCLUDE 'COMMON.LOCAL'
2088       INCLUDE 'COMMON.NAMES'
2089       INCLUDE 'COMMON.VAR'
2090       double precision scalar, facd4, federmaus
2091       alphapol1 = alphapol(itypi,itypj)
2092 c! R1 - distance between head of ith side chain and tail of jth sidechain
2093        R1 = 0.0d0
2094        DO k = 1, 3
2095 c! Calculate head-to-tail distances
2096         R1=R1+(ctail(k,2)-chead(k,1))**2
2097        END DO
2098 c! Pitagoras
2099        R1 = dsqrt(R1)
2100
2101 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2102 c!     &        +dhead(1,1,itypi,itypj))**2))
2103 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2104 c!     &        +dhead(2,1,itypi,itypj))**2))
2105 c--------------------------------------------------------------------
2106 c Polarization energy
2107 c Epol
2108        MomoFac1 = (1.0d0 - chi1 * sqom2)
2109        RR1  = R1 * R1 / MomoFac1
2110        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2111        fgb1 = sqrt( RR1 + a12sq * ee1)
2112        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2113 c!       epol = 0.0d0
2114 c!------------------------------------------------------------------
2115 c! derivative of Epol is Gpol...
2116        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2117      &          / (fgb1 ** 5.0d0)
2118        dFGBdR1 = ( (R1 / MomoFac1)
2119      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2120      &        / ( 2.0d0 * fgb1 )
2121        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2122      &          * (2.0d0 - 0.5d0 * ee1) )
2123      &          / (2.0d0 * fgb1)
2124        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2125 c!       dPOLdR1 = 0.0d0
2126        dPOLdOM1 = 0.0d0
2127        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2128 c!       dPOLdOM2 = 0.0d0
2129 c!-------------------------------------------------------------------
2130 c! Return the results
2131 c! (see comments in Eqq)
2132        DO k = 1, 3
2133         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2134        END DO
2135        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2136        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2137        facd1 = d1 * vbld_inv(i+nres)
2138        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2139
2140        DO k = 1, 3
2141         hawk = (erhead_tail(k,1) +
2142      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2143
2144         gvdwx(k,i) = gvdwx(k,i)
2145      &             - dPOLdR1 * hawk
2146         gvdwx(k,j) = gvdwx(k,j)
2147      &             + dPOLdR1 * (erhead_tail(k,1)
2148      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2149
2150         gvdwc(k,i) = gvdwc(k,i)
2151      &             - dPOLdR1 * erhead_tail(k,1)
2152         gvdwc(k,j) = gvdwc(k,j)
2153      &             + dPOLdR1 * erhead_tail(k,1)
2154
2155        END DO
2156        RETURN
2157       END SUBROUTINE eqn
2158
2159
2160 c!-------------------------------------------------------------------
2161
2162
2163
2164       SUBROUTINE enq(Epol)
2165        IMPLICIT NONE
2166        INCLUDE 'DIMENSIONS'
2167        INCLUDE 'DIMENSIONS.ZSCOPT'
2168        INCLUDE 'COMMON.CALC'
2169        INCLUDE 'COMMON.CHAIN'
2170        INCLUDE 'COMMON.CONTROL'
2171        INCLUDE 'COMMON.DERIV'
2172        INCLUDE 'COMMON.EMP'
2173        INCLUDE 'COMMON.GEO'
2174        INCLUDE 'COMMON.INTERACT'
2175        INCLUDE 'COMMON.IOUNITS'
2176        INCLUDE 'COMMON.LOCAL'
2177        INCLUDE 'COMMON.NAMES'
2178        INCLUDE 'COMMON.VAR'
2179        double precision scalar, facd3, adler
2180        alphapol2 = alphapol(itypj,itypi)
2181 c! R2 - distance between head of jth side chain and tail of ith sidechain
2182        R2 = 0.0d0
2183        DO k = 1, 3
2184 c! Calculate head-to-tail distances
2185         R2=R2+(chead(k,2)-ctail(k,1))**2
2186        END DO
2187 c! Pitagoras
2188        R2 = dsqrt(R2)
2189
2190 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2191 c!     &        +dhead(1,1,itypi,itypj))**2))
2192 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2193 c!     &        +dhead(2,1,itypi,itypj))**2))
2194 c------------------------------------------------------------------------
2195 c Polarization energy
2196        MomoFac2 = (1.0d0 - chi2 * sqom1)
2197        RR2  = R2 * R2 / MomoFac2
2198        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2199        fgb2 = sqrt(RR2  + a12sq * ee2)
2200        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2201 c!       epol = 0.0d0
2202 c!-------------------------------------------------------------------
2203 c! derivative of Epol is Gpol...
2204        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2205      &          / (fgb2 ** 5.0d0)
2206        dFGBdR2 = ( (R2 / MomoFac2)
2207      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2208      &        / (2.0d0 * fgb2)
2209        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2210      &          * (2.0d0 - 0.5d0 * ee2) )
2211      &          / (2.0d0 * fgb2)
2212        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2213 c!       dPOLdR2 = 0.0d0
2214        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2215 c!       dPOLdOM1 = 0.0d0
2216        dPOLdOM2 = 0.0d0
2217 c!-------------------------------------------------------------------
2218 c! Return the results
2219 c! (See comments in Eqq)
2220        DO k = 1, 3
2221         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2222        END DO
2223        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2224        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2225        facd2 = d2 * vbld_inv(j+nres)
2226        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2227        DO k = 1, 3
2228         condor = (erhead_tail(k,2)
2229      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2230
2231         gvdwx(k,i) = gvdwx(k,i)
2232      &             - dPOLdR2 * (erhead_tail(k,2)
2233      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2234         gvdwx(k,j) = gvdwx(k,j)
2235      &             + dPOLdR2 * condor
2236
2237         gvdwc(k,i) = gvdwc(k,i)
2238      &             - dPOLdR2 * erhead_tail(k,2)
2239         gvdwc(k,j) = gvdwc(k,j)
2240      &             + dPOLdR2 * erhead_tail(k,2)
2241
2242        END DO
2243       RETURN
2244       END SUBROUTINE enq
2245
2246
2247 c!-------------------------------------------------------------------
2248
2249
2250       SUBROUTINE eqd(Ecl,Elj,Epol)
2251        IMPLICIT NONE
2252        INCLUDE 'DIMENSIONS'
2253        INCLUDE 'DIMENSIONS.ZSCOPT'
2254        INCLUDE 'COMMON.CALC'
2255        INCLUDE 'COMMON.CHAIN'
2256        INCLUDE 'COMMON.CONTROL'
2257        INCLUDE 'COMMON.DERIV'
2258        INCLUDE 'COMMON.EMP'
2259        INCLUDE 'COMMON.GEO'
2260        INCLUDE 'COMMON.INTERACT'
2261        INCLUDE 'COMMON.IOUNITS'
2262        INCLUDE 'COMMON.LOCAL'
2263        INCLUDE 'COMMON.NAMES'
2264        INCLUDE 'COMMON.VAR'
2265        double precision scalar, facd4, federmaus
2266        alphapol1 = alphapol(itypi,itypj)
2267        w1        = wqdip(1,itypi,itypj)
2268        w2        = wqdip(2,itypi,itypj)
2269        pis       = sig0head(itypi,itypj)
2270        eps_head   = epshead(itypi,itypj)
2271 c!-------------------------------------------------------------------
2272 c! R1 - distance between head of ith side chain and tail of jth sidechain
2273        R1 = 0.0d0
2274        DO k = 1, 3
2275 c! Calculate head-to-tail distances
2276         R1=R1+(ctail(k,2)-chead(k,1))**2
2277        END DO
2278 c! Pitagoras
2279        R1 = dsqrt(R1)
2280
2281 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2282 c!     &        +dhead(1,1,itypi,itypj))**2))
2283 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2284 c!     &        +dhead(2,1,itypi,itypj))**2))
2285
2286 c!-------------------------------------------------------------------
2287 c! ecl
2288        sparrow  = w1 * Qi * om1
2289        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2290        Ecl = sparrow / Rhead**2.0d0
2291      &     - hawk    / Rhead**4.0d0
2292 c!-------------------------------------------------------------------
2293 c! derivative of ecl is Gcl
2294 c! dF/dr part
2295        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2296      &           + 4.0d0 * hawk    / Rhead**5.0d0
2297 c! dF/dom1
2298        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2299 c! dF/dom2
2300        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2301 c--------------------------------------------------------------------
2302 c Polarization energy
2303 c Epol
2304        MomoFac1 = (1.0d0 - chi1 * sqom2)
2305        RR1  = R1 * R1 / MomoFac1
2306        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2307        fgb1 = sqrt( RR1 + a12sq * ee1)
2308        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2309 c!       epol = 0.0d0
2310 c!------------------------------------------------------------------
2311 c! derivative of Epol is Gpol...
2312        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2313      &          / (fgb1 ** 5.0d0)
2314        dFGBdR1 = ( (R1 / MomoFac1)
2315      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2316      &        / ( 2.0d0 * fgb1 )
2317        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2318      &          * (2.0d0 - 0.5d0 * ee1) )
2319      &          / (2.0d0 * fgb1)
2320        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2321 c!       dPOLdR1 = 0.0d0
2322        dPOLdOM1 = 0.0d0
2323        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2324 c!       dPOLdOM2 = 0.0d0
2325 c!-------------------------------------------------------------------
2326 c! Elj
2327        pom = (pis / Rhead)**6.0d0
2328        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2329 c! derivative of Elj is Glj
2330        dGLJdR = 4.0d0 * eps_head
2331      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2332      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2333 c!-------------------------------------------------------------------
2334 c! Return the results
2335        DO k = 1, 3
2336         erhead(k) = Rhead_distance(k)/Rhead
2337         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2338        END DO
2339
2340        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2341        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2342        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2343        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2344        facd1 = d1 * vbld_inv(i+nres)
2345        facd2 = d2 * vbld_inv(j+nres)
2346        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2347
2348        DO k = 1, 3
2349         hawk = (erhead_tail(k,1) +
2350      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2351
2352         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2353         gvdwx(k,i) = gvdwx(k,i)
2354      &             - dGCLdR * pom
2355      &             - dPOLdR1 * hawk
2356      &             - dGLJdR * pom
2357
2358         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2359         gvdwx(k,j) = gvdwx(k,j)
2360      &             + dGCLdR * pom
2361      &             + dPOLdR1 * (erhead_tail(k,1)
2362      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2363      &             + dGLJdR * pom
2364
2365
2366         gvdwc(k,i) = gvdwc(k,i)
2367      &             - dGCLdR * erhead(k)
2368      &             - dPOLdR1 * erhead_tail(k,1)
2369      &             - dGLJdR * erhead(k)
2370
2371         gvdwc(k,j) = gvdwc(k,j)
2372      &             + dGCLdR * erhead(k)
2373      &             + dPOLdR1 * erhead_tail(k,1)
2374      &             + dGLJdR * erhead(k)
2375
2376        END DO
2377        RETURN
2378       END SUBROUTINE eqd
2379
2380
2381 c!-------------------------------------------------------------------
2382
2383
2384       SUBROUTINE edq(Ecl,Elj,Epol)
2385        IMPLICIT NONE
2386        INCLUDE 'DIMENSIONS'
2387        INCLUDE 'DIMENSIONS.ZSCOPT'
2388        INCLUDE 'COMMON.CALC'
2389        INCLUDE 'COMMON.CHAIN'
2390        INCLUDE 'COMMON.CONTROL'
2391        INCLUDE 'COMMON.DERIV'
2392        INCLUDE 'COMMON.EMP'
2393        INCLUDE 'COMMON.GEO'
2394        INCLUDE 'COMMON.INTERACT'
2395        INCLUDE 'COMMON.IOUNITS'
2396        INCLUDE 'COMMON.LOCAL'
2397        INCLUDE 'COMMON.NAMES'
2398        INCLUDE 'COMMON.VAR'
2399        double precision scalar, facd3, adler
2400        alphapol2 = alphapol(itypj,itypi)
2401        w1        = wqdip(1,itypi,itypj)
2402        w2        = wqdip(2,itypi,itypj)
2403        pis       = sig0head(itypi,itypj)
2404        eps_head  = epshead(itypi,itypj)
2405 c!-------------------------------------------------------------------
2406 c! R2 - distance between head of jth side chain and tail of ith sidechain
2407        R2 = 0.0d0
2408        DO k = 1, 3
2409 c! Calculate head-to-tail distances
2410         R2=R2+(chead(k,2)-ctail(k,1))**2
2411        END DO
2412 c! Pitagoras
2413        R2 = dsqrt(R2)
2414
2415 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2416 c!     &        +dhead(1,1,itypi,itypj))**2))
2417 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2418 c!     &        +dhead(2,1,itypi,itypj))**2))
2419
2420
2421 c!-------------------------------------------------------------------
2422 c! ecl
2423        sparrow  = w1 * Qi * om1
2424        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2425        ECL = sparrow / Rhead**2.0d0
2426      &     - hawk    / Rhead**4.0d0
2427 c!-------------------------------------------------------------------
2428 c! derivative of ecl is Gcl
2429 c! dF/dr part
2430        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2431      &           + 4.0d0 * hawk    / Rhead**5.0d0
2432 c! dF/dom1
2433        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2434 c! dF/dom2
2435        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2436 c--------------------------------------------------------------------
2437 c Polarization energy
2438 c Epol
2439        MomoFac2 = (1.0d0 - chi2 * sqom1)
2440        RR2  = R2 * R2 / MomoFac2
2441        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2442        fgb2 = sqrt(RR2  + a12sq * ee2)
2443        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2444 c!       epol = 0.0d0
2445 c! derivative of Epol is Gpol...
2446        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2447      &          / (fgb2 ** 5.0d0)
2448        dFGBdR2 = ( (R2 / MomoFac2)
2449      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2450      &        / (2.0d0 * fgb2)
2451        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2452      &          * (2.0d0 - 0.5d0 * ee2) )
2453      &          / (2.0d0 * fgb2)
2454        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2455 c!       dPOLdR2 = 0.0d0
2456        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2457 c!       dPOLdOM1 = 0.0d0
2458        dPOLdOM2 = 0.0d0
2459 c!-------------------------------------------------------------------
2460 c! Elj
2461        pom = (pis / Rhead)**6.0d0
2462        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2463 c! derivative of Elj is Glj
2464        dGLJdR = 4.0d0 * eps_head
2465      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2466      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2467 c!-------------------------------------------------------------------
2468 c! Return the results
2469 c! (see comments in Eqq)
2470        DO k = 1, 3
2471         erhead(k) = Rhead_distance(k)/Rhead
2472         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2473        END DO
2474        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2475        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2476        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2477        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2478        facd1 = d1 * vbld_inv(i+nres)
2479        facd2 = d2 * vbld_inv(j+nres)
2480        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2481
2482        DO k = 1, 3
2483         condor = (erhead_tail(k,2)
2484      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2485
2486         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2487         gvdwx(k,i) = gvdwx(k,i)
2488      &             - dGCLdR * pom
2489      &             - dPOLdR2 * (erhead_tail(k,2)
2490      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2491      &             - dGLJdR * pom
2492
2493         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2494         gvdwx(k,j) = gvdwx(k,j)
2495      &             + dGCLdR * pom
2496      &             + dPOLdR2 * condor
2497      &             + dGLJdR * pom
2498
2499
2500         gvdwc(k,i) = gvdwc(k,i)
2501      &             - dGCLdR * erhead(k)
2502      &             - dPOLdR2 * erhead_tail(k,2)
2503      &             - dGLJdR * erhead(k)
2504
2505         gvdwc(k,j) = gvdwc(k,j)
2506      &             + dGCLdR * erhead(k)
2507      &             + dPOLdR2 * erhead_tail(k,2)
2508      &             + dGLJdR * erhead(k)
2509
2510        END DO
2511        RETURN
2512       END SUBROUTINE edq
2513
2514
2515 C--------------------------------------------------------------------
2516
2517
2518       SUBROUTINE edd(ECL)
2519        IMPLICIT NONE
2520        INCLUDE 'DIMENSIONS'
2521        INCLUDE 'DIMENSIONS.ZSCOPT'
2522        INCLUDE 'COMMON.CALC'
2523        INCLUDE 'COMMON.CHAIN'
2524        INCLUDE 'COMMON.CONTROL'
2525        INCLUDE 'COMMON.DERIV'
2526        INCLUDE 'COMMON.EMP'
2527        INCLUDE 'COMMON.GEO'
2528        INCLUDE 'COMMON.INTERACT'
2529        INCLUDE 'COMMON.IOUNITS'
2530        INCLUDE 'COMMON.LOCAL'
2531        INCLUDE 'COMMON.NAMES'
2532        INCLUDE 'COMMON.VAR'
2533        double precision scalar
2534 c!       csig = sigiso(itypi,itypj)
2535        w1 = wqdip(1,itypi,itypj)
2536        w2 = wqdip(2,itypi,itypj)
2537 c!-------------------------------------------------------------------
2538 c! ECL
2539        fac = (om12 - 3.0d0 * om1 * om2)
2540        c1 = (w1 / (Rhead**3.0d0)) * fac
2541        c2 = (w2 / Rhead ** 6.0d0)
2542      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2543        ECL = c1 - c2
2544 c!       write (*,*) "w1 = ", w1
2545 c!       write (*,*) "w2 = ", w2
2546 c!       write (*,*) "om1 = ", om1
2547 c!       write (*,*) "om2 = ", om2
2548 c!       write (*,*) "om12 = ", om12
2549 c!       write (*,*) "fac = ", fac
2550 c!       write (*,*) "c1 = ", c1
2551 c!       write (*,*) "c2 = ", c2
2552 c!       write (*,*) "Ecl = ", Ecl
2553 c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
2554 c!       write (*,*) "c2_2 = ",
2555 c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2556 c!-------------------------------------------------------------------
2557 c! dervative of ECL is GCL...
2558 c! dECL/dr
2559        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
2560        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)
2561      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
2562        dGCLdR = c1 - c2
2563 c! dECL/dom1
2564        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
2565        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2566      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
2567        dGCLdOM1 = c1 - c2
2568 c! dECL/dom2
2569        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
2570        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2571      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
2572        dGCLdOM2 = c1 - c2
2573 c! dECL/dom12
2574        c1 = w1 / (Rhead ** 3.0d0)
2575        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
2576        dGCLdOM12 = c1 - c2
2577 c!-------------------------------------------------------------------
2578 c! Return the results
2579 c! (see comments in Eqq)
2580        DO k= 1, 3
2581         erhead(k) = Rhead_distance(k)/Rhead
2582        END DO
2583        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2584        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2585        facd1 = d1 * vbld_inv(i+nres)
2586        facd2 = d2 * vbld_inv(j+nres)
2587        DO k = 1, 3
2588
2589         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2590         gvdwx(k,i) = gvdwx(k,i)
2591      &             - dGCLdR * pom
2592         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2593         gvdwx(k,j) = gvdwx(k,j)
2594      &             + dGCLdR * pom
2595
2596         gvdwc(k,i) = gvdwc(k,i)
2597      &             - dGCLdR * erhead(k)
2598         gvdwc(k,j) = gvdwc(k,j)
2599      &             + dGCLdR * erhead(k)
2600        END DO
2601        RETURN
2602       END SUBROUTINE edd
2603
2604
2605 c!-------------------------------------------------------------------
2606
2607
2608       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
2609        IMPLICIT NONE
2610 c! maxres
2611        INCLUDE 'DIMENSIONS'
2612 c! itypi, itypj, i, j, k, l, chead,
2613        INCLUDE 'COMMON.CALC'
2614 c! c, nres, dc_norm
2615        INCLUDE 'COMMON.CHAIN'
2616 c! gradc, gradx
2617        INCLUDE 'COMMON.DERIV'
2618 c! electrostatic gradients-specific variables
2619        INCLUDE 'COMMON.EMP'
2620 c! wquad, dhead, alphiso, alphasur, rborn, epsintab
2621        INCLUDE 'COMMON.INTERACT'
2622 c! io for debug, disable it in final builds
2623        INCLUDE 'COMMON.IOUNITS'
2624 c!-------------------------------------------------------------------
2625 c! Variable Init
2626
2627 c! what amino acid is the aminoacid j'th?
2628        itypj = itype(j)
2629 c! 1/(Gas Constant * Thermostate temperature) = BetaT
2630 c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
2631        BetaT = 1.0d0 / (298 * 1.987d-3)
2632 c! Gay-berne var's
2633        sig0ij = sigma( itypi,itypj )
2634        chi1   = chi( itypi, itypj )
2635        chi2   = chi( itypj, itypi )
2636        chi12  = chi1 * chi2
2637        chip1  = chipp( itypi, itypj )
2638        chip2  = chipp( itypj, itypi )
2639        chip12 = chip1 * chip2
2640 c!       write (2,*) "elgrad types",itypi,itypj,
2641 c!     & " chi1",chi1," chi2",chi2," chi12",chi12,
2642 c!     &  " chip1",chip1," chip2",chip2," chip12",chip12
2643 c! not used by momo potential, but needed by sc_angular which is shared
2644 c! by all energy_potential subroutines
2645        alf1   = 0.0d0
2646        alf2   = 0.0d0
2647        alf12  = 0.0d0
2648 c! location, location, location
2649        xj  = c( 1, nres+j ) - xi
2650        yj  = c( 2, nres+j ) - yi
2651        zj  = c( 3, nres+j ) - zi
2652        dxj = dc_norm( 1, nres+j )
2653        dyj = dc_norm( 2, nres+j )
2654        dzj = dc_norm( 3, nres+j )
2655 c! distance from center of chain(?) to polar/charged head
2656 c!       write (*,*) "istate = ", 1
2657 c!       write (*,*) "ii = ", 1
2658 c!       write (*,*) "jj = ", 1
2659        d1 = dhead(1, 1, itypi, itypj)
2660        d2 = dhead(2, 1, itypi, itypj)
2661 c! ai*aj from Fgb
2662        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
2663 c!       a12sq = a12sq * a12sq
2664 c! charge of amino acid itypi is...
2665        Qi  = icharge(itypi)
2666        Qj  = icharge(itypj)
2667        Qij = Qi * Qj
2668 c! chis1,2,12
2669        chis1 = chis(itypi,itypj)
2670        chis2 = chis(itypj,itypi)
2671        chis12 = chis1 * chis2
2672        sig1 = sigmap1(itypi,itypj)
2673        sig2 = sigmap2(itypi,itypj)
2674 c!       write (*,*) "sig1 = ", sig1
2675 c!       write (*,*) "sig2 = ", sig2
2676 c! alpha factors from Fcav/Gcav
2677        b1 = alphasur(1,itypi,itypj)
2678        b2 = alphasur(2,itypi,itypj)
2679        b3 = alphasur(3,itypi,itypj)
2680        b4 = alphasur(4,itypi,itypj)
2681 c! used to determine whether we want to do quadrupole calculations
2682        wqd = wquad(itypi, itypj)
2683 c! used by Fgb
2684        eps_in = epsintab(itypi,itypj)
2685        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
2686 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
2687 c!-------------------------------------------------------------------
2688 c! tail location and distance calculations
2689        Rtail = 0.0d0
2690        DO k = 1, 3
2691         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
2692         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
2693        END DO
2694 c! tail distances will be themselves usefull elswhere
2695 c1 (in Gcav, for example)
2696        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
2697        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
2698        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
2699        Rtail = dsqrt(
2700      &     (Rtail_distance(1)*Rtail_distance(1))
2701      &   + (Rtail_distance(2)*Rtail_distance(2))
2702      &   + (Rtail_distance(3)*Rtail_distance(3)))
2703 c!-------------------------------------------------------------------
2704 c! Calculate location and distance between polar heads
2705 c! distance between heads
2706 c! for each one of our three dimensional space...
2707        DO k = 1,3
2708 c! location of polar head is computed by taking hydrophobic centre
2709 c! and moving by a d1 * dc_norm vector
2710 c! see unres publications for very informative images
2711         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
2712         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
2713 c! distance
2714 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
2715 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
2716         Rhead_distance(k) = chead(k,2) - chead(k,1)
2717        END DO
2718 c! pitagoras (root of sum of squares)
2719        Rhead = dsqrt(
2720      &     (Rhead_distance(1)*Rhead_distance(1))
2721      &   + (Rhead_distance(2)*Rhead_distance(2))
2722      &   + (Rhead_distance(3)*Rhead_distance(3)))
2723 c!-------------------------------------------------------------------
2724 c! zero everything that should be zero'ed
2725        Egb = 0.0d0
2726        ECL = 0.0d0
2727        Elj = 0.0d0
2728        Equad = 0.0d0
2729        Epol = 0.0d0
2730        eheadtail = 0.0d0
2731        dGCLdOM1 = 0.0d0
2732        dGCLdOM2 = 0.0d0
2733        dGCLdOM12 = 0.0d0
2734        dPOLdOM1 = 0.0d0
2735        dPOLdOM2 = 0.0d0
2736        RETURN
2737       END SUBROUTINE elgrad_init
2738 c!-------------------------------------------------------------------
2739       subroutine sc_angular
2740 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2741 C om12. Called by ebp, egb, and egbv.
2742       implicit none
2743       include 'COMMON.CALC'
2744       include 'COMMON.IOUNITS'
2745       erij(1)=xj*rij
2746       erij(2)=yj*rij
2747       erij(3)=zj*rij
2748       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2749       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2750       om12=dxi*dxj+dyi*dyj+dzi*dzj
2751 c!      om1    = 0.0d0
2752 c!      om2    = 0.0d0
2753 c!      om12   = 0.0d0
2754       chiom12=chi12*om12
2755 C Calculate eps1(om12) and its derivative in om12
2756       faceps1=1.0D0-om12*chiom12
2757       faceps1_inv=1.0D0/faceps1
2758       eps1=dsqrt(faceps1_inv)
2759 c      write (2,*) "chi1",chi1," chi2",chi2," chi12",chi12
2760 c      write (2,*) "fsceps1",faceps1," faceps1_inv",faceps1_inv,
2761 c     & " eps1",eps1
2762 C Following variable is eps1*deps1/dom12
2763       eps1_om12=faceps1_inv*chiom12
2764 c diagnostics only
2765 c      faceps1_inv=om12
2766 c      eps1=om12
2767 c      eps1_om12=1.0d0
2768 c      write (iout,*) "om12",om12," eps1",eps1
2769 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2770 C and om12.
2771       om1om2=om1*om2
2772       chiom1=chi1*om1
2773       chiom2=chi2*om2
2774       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2775       sigsq=1.0D0-facsig*faceps1_inv
2776 c      write (2,*) "om1",om1," om2",om2," om1om2",om1om2,
2777 c     & " chiom1",chiom1,
2778 c     &  " chiom2",chiom2," facsig",facsig," sigsq",sigsq
2779       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2780       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2781       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2782 c diagnostics only
2783 c      sigsq=1.0d0
2784 c      sigsq_om1=0.0d0
2785 c      sigsq_om2=0.0d0
2786 c      sigsq_om12=0.0d0
2787 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2788 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2789 c     &    " eps1",eps1
2790 C Calculate eps2 and its derivatives in om1, om2, and om12.
2791       chipom1=chip1*om1
2792       chipom2=chip2*om2
2793       chipom12=chip12*om12
2794       facp=1.0D0-om12*chipom12
2795       facp_inv=1.0D0/facp
2796       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2797 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2798 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2799 C Following variable is the square root of eps2
2800       eps2rt=1.0D0-facp1*facp_inv
2801 C Following three variables are the derivatives of the square root of eps
2802 C in om1, om2, and om12.
2803       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2804       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2805       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2806 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2807 c! Note that THIS is 0 in emomo, so we should probably move it out of sc_angular
2808 c! Or frankly, we should restructurize the whole energy section
2809       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2810 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2811 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2812 c     &  " eps2rt_om12",eps2rt_om12
2813 C Calculate whole angle-dependent part of epsilon and contributions
2814 C to its derivatives
2815       return
2816       end
2817 C----------------------------------------------------------------------------
2818       subroutine sc_grad
2819       implicit real*8 (a-h,o-z)
2820       include 'DIMENSIONS'
2821       include 'DIMENSIONS.ZSCOPT'
2822       include 'COMMON.CHAIN'
2823       include 'COMMON.DERIV'
2824       include 'COMMON.CALC'
2825       double precision dcosom1(3),dcosom2(3)
2826       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2827       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2828       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2829      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2830       do k=1,3
2831         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2832         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2833       enddo
2834       do k=1,3
2835         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2836       enddo
2837       do k=1,3
2838         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2839      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2840      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2841         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2842      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2843      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2844       enddo
2845 C
2846 C Calculate the components of the gradient in DC and X
2847 C
2848       do k=i,j-1
2849         do l=1,3
2850           gvdwc(l,k)=gvdwc(l,k)+gg(l)
2851         enddo
2852       enddo
2853       return
2854       end
2855 c------------------------------------------------------------------------------
2856       subroutine vec_and_deriv
2857       implicit real*8 (a-h,o-z)
2858       include 'DIMENSIONS'
2859       include 'DIMENSIONS.ZSCOPT'
2860       include 'COMMON.IOUNITS'
2861       include 'COMMON.GEO'
2862       include 'COMMON.VAR'
2863       include 'COMMON.LOCAL'
2864       include 'COMMON.CHAIN'
2865       include 'COMMON.VECTORS'
2866       include 'COMMON.DERIV'
2867       include 'COMMON.INTERACT'
2868       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2869 C Compute the local reference systems. For reference system (i), the
2870 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2871 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2872       do i=1,nres-1
2873 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
2874           if (i.eq.nres-1) then
2875 C Case of the last full residue
2876 C Compute the Z-axis
2877             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2878             costh=dcos(pi-theta(nres))
2879             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2880             do k=1,3
2881               uz(k,i)=fac*uz(k,i)
2882             enddo
2883             if (calc_grad) then
2884 C Compute the derivatives of uz
2885             uzder(1,1,1)= 0.0d0
2886             uzder(2,1,1)=-dc_norm(3,i-1)
2887             uzder(3,1,1)= dc_norm(2,i-1)
2888             uzder(1,2,1)= dc_norm(3,i-1)
2889             uzder(2,2,1)= 0.0d0
2890             uzder(3,2,1)=-dc_norm(1,i-1)
2891             uzder(1,3,1)=-dc_norm(2,i-1)
2892             uzder(2,3,1)= dc_norm(1,i-1)
2893             uzder(3,3,1)= 0.0d0
2894             uzder(1,1,2)= 0.0d0
2895             uzder(2,1,2)= dc_norm(3,i)
2896             uzder(3,1,2)=-dc_norm(2,i)
2897             uzder(1,2,2)=-dc_norm(3,i)
2898             uzder(2,2,2)= 0.0d0
2899             uzder(3,2,2)= dc_norm(1,i)
2900             uzder(1,3,2)= dc_norm(2,i)
2901             uzder(2,3,2)=-dc_norm(1,i)
2902             uzder(3,3,2)= 0.0d0
2903             endif
2904 C Compute the Y-axis
2905             facy=fac
2906             do k=1,3
2907               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2908             enddo
2909             if (calc_grad) then
2910 C Compute the derivatives of uy
2911             do j=1,3
2912               do k=1,3
2913                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2914      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2915                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2916               enddo
2917               uyder(j,j,1)=uyder(j,j,1)-costh
2918               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2919             enddo
2920             do j=1,2
2921               do k=1,3
2922                 do l=1,3
2923                   uygrad(l,k,j,i)=uyder(l,k,j)
2924                   uzgrad(l,k,j,i)=uzder(l,k,j)
2925                 enddo
2926               enddo
2927             enddo
2928             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2929             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2930             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2931             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2932             endif
2933           else
2934 C Other residues
2935 C Compute the Z-axis
2936             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2937             costh=dcos(pi-theta(i+2))
2938             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2939             do k=1,3
2940               uz(k,i)=fac*uz(k,i)
2941             enddo
2942             if (calc_grad) then
2943 C Compute the derivatives of uz
2944             uzder(1,1,1)= 0.0d0
2945             uzder(2,1,1)=-dc_norm(3,i+1)
2946             uzder(3,1,1)= dc_norm(2,i+1)
2947             uzder(1,2,1)= dc_norm(3,i+1)
2948             uzder(2,2,1)= 0.0d0
2949             uzder(3,2,1)=-dc_norm(1,i+1)
2950             uzder(1,3,1)=-dc_norm(2,i+1)
2951             uzder(2,3,1)= dc_norm(1,i+1)
2952             uzder(3,3,1)= 0.0d0
2953             uzder(1,1,2)= 0.0d0
2954             uzder(2,1,2)= dc_norm(3,i)
2955             uzder(3,1,2)=-dc_norm(2,i)
2956             uzder(1,2,2)=-dc_norm(3,i)
2957             uzder(2,2,2)= 0.0d0
2958             uzder(3,2,2)= dc_norm(1,i)
2959             uzder(1,3,2)= dc_norm(2,i)
2960             uzder(2,3,2)=-dc_norm(1,i)
2961             uzder(3,3,2)= 0.0d0
2962             endif
2963 C Compute the Y-axis
2964             facy=fac
2965             do k=1,3
2966               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2967             enddo
2968             if (calc_grad) then
2969 C Compute the derivatives of uy
2970             do j=1,3
2971               do k=1,3
2972                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2973      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2974                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2975               enddo
2976               uyder(j,j,1)=uyder(j,j,1)-costh
2977               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2978             enddo
2979             do j=1,2
2980               do k=1,3
2981                 do l=1,3
2982                   uygrad(l,k,j,i)=uyder(l,k,j)
2983                   uzgrad(l,k,j,i)=uzder(l,k,j)
2984                 enddo
2985               enddo
2986             enddo
2987             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2988             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2989             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2990             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2991           endif
2992           endif
2993       enddo
2994       if (calc_grad) then
2995       do i=1,nres-1
2996         vbld_inv_temp(1)=vbld_inv(i+1)
2997         if (i.lt.nres-1) then
2998           vbld_inv_temp(2)=vbld_inv(i+2)
2999         else
3000           vbld_inv_temp(2)=vbld_inv(i)
3001         endif
3002         do j=1,2
3003           do k=1,3
3004             do l=1,3
3005               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
3006               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
3007             enddo
3008           enddo
3009         enddo
3010       enddo
3011       endif
3012       return
3013       end
3014 C-----------------------------------------------------------------------------
3015       subroutine vec_and_deriv_test
3016       implicit real*8 (a-h,o-z)
3017       include 'DIMENSIONS'
3018       include 'DIMENSIONS.ZSCOPT'
3019       include 'COMMON.IOUNITS'
3020       include 'COMMON.GEO'
3021       include 'COMMON.VAR'
3022       include 'COMMON.LOCAL'
3023       include 'COMMON.CHAIN'
3024       include 'COMMON.VECTORS'
3025       dimension uyder(3,3,2),uzder(3,3,2)
3026 C Compute the local reference systems. For reference system (i), the
3027 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
3028 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
3029       do i=1,nres-1
3030           if (i.eq.nres-1) then
3031 C Case of the last full residue
3032 C Compute the Z-axis
3033             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
3034             costh=dcos(pi-theta(nres))
3035             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3036 c            write (iout,*) 'fac',fac,
3037 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3038             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3039             do k=1,3
3040               uz(k,i)=fac*uz(k,i)
3041             enddo
3042 C Compute the derivatives of uz
3043             uzder(1,1,1)= 0.0d0
3044             uzder(2,1,1)=-dc_norm(3,i-1)
3045             uzder(3,1,1)= dc_norm(2,i-1)
3046             uzder(1,2,1)= dc_norm(3,i-1)
3047             uzder(2,2,1)= 0.0d0
3048             uzder(3,2,1)=-dc_norm(1,i-1)
3049             uzder(1,3,1)=-dc_norm(2,i-1)
3050             uzder(2,3,1)= dc_norm(1,i-1)
3051             uzder(3,3,1)= 0.0d0
3052             uzder(1,1,2)= 0.0d0
3053             uzder(2,1,2)= dc_norm(3,i)
3054             uzder(3,1,2)=-dc_norm(2,i)
3055             uzder(1,2,2)=-dc_norm(3,i)
3056             uzder(2,2,2)= 0.0d0
3057             uzder(3,2,2)= dc_norm(1,i)
3058             uzder(1,3,2)= dc_norm(2,i)
3059             uzder(2,3,2)=-dc_norm(1,i)
3060             uzder(3,3,2)= 0.0d0
3061 C Compute the Y-axis
3062             do k=1,3
3063               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
3064             enddo
3065             facy=fac
3066             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
3067      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
3068      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
3069             do k=1,3
3070 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3071               uy(k,i)=
3072 c     &        facy*(
3073      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
3074      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
3075 c     &        )
3076             enddo
3077 c            write (iout,*) 'facy',facy,
3078 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3079             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3080             do k=1,3
3081               uy(k,i)=facy*uy(k,i)
3082             enddo
3083 C Compute the derivatives of uy
3084             do j=1,3
3085               do k=1,3
3086                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
3087      &                        -dc_norm(k,i)*dc_norm(j,i-1)
3088                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3089               enddo
3090 c              uyder(j,j,1)=uyder(j,j,1)-costh
3091 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
3092               uyder(j,j,1)=uyder(j,j,1)
3093      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
3094               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
3095      &          +uyder(j,j,2)
3096             enddo
3097             do j=1,2
3098               do k=1,3
3099                 do l=1,3
3100                   uygrad(l,k,j,i)=uyder(l,k,j)
3101                   uzgrad(l,k,j,i)=uzder(l,k,j)
3102                 enddo
3103               enddo
3104             enddo
3105             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3106             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3107             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3108             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3109           else
3110 C Other residues
3111 C Compute the Z-axis
3112             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
3113             costh=dcos(pi-theta(i+2))
3114             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3115             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3116             do k=1,3
3117               uz(k,i)=fac*uz(k,i)
3118             enddo
3119 C Compute the derivatives of uz
3120             uzder(1,1,1)= 0.0d0
3121             uzder(2,1,1)=-dc_norm(3,i+1)
3122             uzder(3,1,1)= dc_norm(2,i+1)
3123             uzder(1,2,1)= dc_norm(3,i+1)
3124             uzder(2,2,1)= 0.0d0
3125             uzder(3,2,1)=-dc_norm(1,i+1)
3126             uzder(1,3,1)=-dc_norm(2,i+1)
3127             uzder(2,3,1)= dc_norm(1,i+1)
3128             uzder(3,3,1)= 0.0d0
3129             uzder(1,1,2)= 0.0d0
3130             uzder(2,1,2)= dc_norm(3,i)
3131             uzder(3,1,2)=-dc_norm(2,i)
3132             uzder(1,2,2)=-dc_norm(3,i)
3133             uzder(2,2,2)= 0.0d0
3134             uzder(3,2,2)= dc_norm(1,i)
3135             uzder(1,3,2)= dc_norm(2,i)
3136             uzder(2,3,2)=-dc_norm(1,i)
3137             uzder(3,3,2)= 0.0d0
3138 C Compute the Y-axis
3139             facy=fac
3140             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
3141      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
3142      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
3143             do k=1,3
3144 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3145               uy(k,i)=
3146 c     &        facy*(
3147      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
3148      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
3149 c     &        )
3150             enddo
3151 c            write (iout,*) 'facy',facy,
3152 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3153             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3154             do k=1,3
3155               uy(k,i)=facy*uy(k,i)
3156             enddo
3157 C Compute the derivatives of uy
3158             do j=1,3
3159               do k=1,3
3160                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
3161      &                        -dc_norm(k,i)*dc_norm(j,i+1)
3162                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3163               enddo
3164 c              uyder(j,j,1)=uyder(j,j,1)-costh
3165 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
3166               uyder(j,j,1)=uyder(j,j,1)
3167      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
3168               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
3169      &          +uyder(j,j,2)
3170             enddo
3171             do j=1,2
3172               do k=1,3
3173                 do l=1,3
3174                   uygrad(l,k,j,i)=uyder(l,k,j)
3175                   uzgrad(l,k,j,i)=uzder(l,k,j)
3176                 enddo
3177               enddo
3178             enddo
3179             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3180             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3181             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3182             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3183           endif
3184       enddo
3185       do i=1,nres-1
3186         do j=1,2
3187           do k=1,3
3188             do l=1,3
3189               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
3190               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
3191             enddo
3192           enddo
3193         enddo
3194       enddo
3195       return
3196       end
3197 C-----------------------------------------------------------------------------
3198       subroutine check_vecgrad
3199       implicit real*8 (a-h,o-z)
3200       include 'DIMENSIONS'
3201       include 'DIMENSIONS.ZSCOPT'
3202       include 'COMMON.IOUNITS'
3203       include 'COMMON.GEO'
3204       include 'COMMON.VAR'
3205       include 'COMMON.LOCAL'
3206       include 'COMMON.CHAIN'
3207       include 'COMMON.VECTORS'
3208       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
3209       dimension uyt(3,maxres),uzt(3,maxres)
3210       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
3211       double precision delta /1.0d-7/
3212       call vec_and_deriv
3213 cd      do i=1,nres
3214 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
3215 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
3216 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
3217 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
3218 cd     &     (dc_norm(if90,i),if90=1,3)
3219 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
3220 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
3221 cd          write(iout,'(a)')
3222 cd      enddo
3223       do i=1,nres
3224         do j=1,2
3225           do k=1,3
3226             do l=1,3
3227               uygradt(l,k,j,i)=uygrad(l,k,j,i)
3228               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
3229             enddo
3230           enddo
3231         enddo
3232       enddo
3233       call vec_and_deriv
3234       do i=1,nres
3235         do j=1,3
3236           uyt(j,i)=uy(j,i)
3237           uzt(j,i)=uz(j,i)
3238         enddo
3239       enddo
3240       do i=1,nres
3241 cd        write (iout,*) 'i=',i
3242         do k=1,3
3243           erij(k)=dc_norm(k,i)
3244         enddo
3245         do j=1,3
3246           do k=1,3
3247             dc_norm(k,i)=erij(k)
3248           enddo
3249           dc_norm(j,i)=dc_norm(j,i)+delta
3250 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
3251 c          do k=1,3
3252 c            dc_norm(k,i)=dc_norm(k,i)/fac
3253 c          enddo
3254 c          write (iout,*) (dc_norm(k,i),k=1,3)
3255 c          write (iout,*) (erij(k),k=1,3)
3256           call vec_and_deriv
3257           do k=1,3
3258             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
3259             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
3260             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
3261             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
3262           enddo
3263 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3264 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
3265 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
3266         enddo
3267         do k=1,3
3268           dc_norm(k,i)=erij(k)
3269         enddo
3270 cd        do k=1,3
3271 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3272 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
3273 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
3274 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3275 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
3276 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
3277 cd          write (iout,'(a)')
3278 cd        enddo
3279       enddo
3280       return
3281       end
3282 C--------------------------------------------------------------------------
3283       subroutine set_matrices
3284       implicit real*8 (a-h,o-z)
3285       include 'DIMENSIONS'
3286       include 'DIMENSIONS.ZSCOPT'
3287       include 'COMMON.IOUNITS'
3288       include 'COMMON.GEO'
3289       include 'COMMON.VAR'
3290       include 'COMMON.LOCAL'
3291       include 'COMMON.CHAIN'
3292       include 'COMMON.DERIV'
3293       include 'COMMON.INTERACT'
3294       include 'COMMON.CONTACTS'
3295       include 'COMMON.TORSION'
3296       include 'COMMON.VECTORS'
3297       include 'COMMON.FFIELD'
3298       double precision auxvec(2),auxmat(2,2)
3299 C
3300 C Compute the virtual-bond-torsional-angle dependent quantities needed
3301 C to calculate the el-loc multibody terms of various order.
3302 C
3303 #ifdef NEWCORR
3304       do i=3,nres+1
3305         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3306           iti = itortyp(itype(i-2))
3307         else
3308           iti=ntortyp+1
3309         endif
3310         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3311           iti1 = itortyp(itype(i-1))
3312         else
3313           iti1=ntortyp+1
3314         endif
3315         b1(1,i-2)=bnew1(1,1,iti)*sin(theta(i-1)/2.0)
3316      &           +bnew1(2,1,iti)*sin(theta(i-1))
3317      &           +bnew1(3,1,iti)*cos(theta(i-1)/2.0)
3318         b2(1,i-2)=bnew2(1,1,iti)*sin(theta(i-1)/2.0)
3319      &           +bnew2(2,1,iti)*sin(theta(i-1))
3320      &           +bnew2(3,1,iti)*cos(theta(i-1)/2.0)
3321         b1(2,i-2)=bnew1(1,2,iti)
3322         b2(2,i-2)=bnew2(1,2,iti)
3323         EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
3324         EE(1,2,i-2)=eeold(1,2,iti)
3325         EE(2,1,i-2)=eeold(2,1,iti)
3326         EE(2,2,i-2)=eeold(2,2,iti)
3327        b1tilde(1,i-2)=b1(1,i-2)
3328        b1tilde(2,i-2)=-b1(2,i-2)
3329        enddo
3330 #endif
3331       do i=3,nres+1
3332         if (i .lt. nres+1) then
3333           sin1=dsin(phi(i))
3334           cos1=dcos(phi(i))
3335           sintab(i-2)=sin1
3336           costab(i-2)=cos1
3337           obrot(1,i-2)=cos1
3338           obrot(2,i-2)=sin1
3339           sin2=dsin(2*phi(i))
3340           cos2=dcos(2*phi(i))
3341           sintab2(i-2)=sin2
3342           costab2(i-2)=cos2
3343           obrot2(1,i-2)=cos2
3344           obrot2(2,i-2)=sin2
3345           Ug(1,1,i-2)=-cos1
3346           Ug(1,2,i-2)=-sin1
3347           Ug(2,1,i-2)=-sin1
3348           Ug(2,2,i-2)= cos1
3349           Ug2(1,1,i-2)=-cos2
3350           Ug2(1,2,i-2)=-sin2
3351           Ug2(2,1,i-2)=-sin2
3352           Ug2(2,2,i-2)= cos2
3353         else
3354           costab(i-2)=1.0d0
3355           sintab(i-2)=0.0d0
3356           obrot(1,i-2)=1.0d0
3357           obrot(2,i-2)=0.0d0
3358           obrot2(1,i-2)=0.0d0
3359           obrot2(2,i-2)=0.0d0
3360           Ug(1,1,i-2)=1.0d0
3361           Ug(1,2,i-2)=0.0d0
3362           Ug(2,1,i-2)=0.0d0
3363           Ug(2,2,i-2)=1.0d0
3364           Ug2(1,1,i-2)=0.0d0
3365           Ug2(1,2,i-2)=0.0d0
3366           Ug2(2,1,i-2)=0.0d0
3367           Ug2(2,2,i-2)=0.0d0
3368         endif
3369         if (i .gt. 3 .and. i .lt. nres+1) then
3370           obrot_der(1,i-2)=-sin1
3371           obrot_der(2,i-2)= cos1
3372           Ugder(1,1,i-2)= sin1
3373           Ugder(1,2,i-2)=-cos1
3374           Ugder(2,1,i-2)=-cos1
3375           Ugder(2,2,i-2)=-sin1
3376           dwacos2=cos2+cos2
3377           dwasin2=sin2+sin2
3378           obrot2_der(1,i-2)=-dwasin2
3379           obrot2_der(2,i-2)= dwacos2
3380           Ug2der(1,1,i-2)= dwasin2
3381           Ug2der(1,2,i-2)=-dwacos2
3382           Ug2der(2,1,i-2)=-dwacos2
3383           Ug2der(2,2,i-2)=-dwasin2
3384         else
3385           obrot_der(1,i-2)=0.0d0
3386           obrot_der(2,i-2)=0.0d0
3387           Ugder(1,1,i-2)=0.0d0
3388           Ugder(1,2,i-2)=0.0d0
3389           Ugder(2,1,i-2)=0.0d0
3390           Ugder(2,2,i-2)=0.0d0
3391           obrot2_der(1,i-2)=0.0d0
3392           obrot2_der(2,i-2)=0.0d0
3393           Ug2der(1,1,i-2)=0.0d0
3394           Ug2der(1,2,i-2)=0.0d0
3395           Ug2der(2,1,i-2)=0.0d0
3396           Ug2der(2,2,i-2)=0.0d0
3397         endif
3398         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3399           iti = itortyp(itype(i-2))
3400         else
3401           iti=ntortyp+1
3402         endif
3403         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3404           iti1 = itortyp(itype(i-1))
3405         else
3406           iti1=ntortyp+1
3407         endif
3408 cd        write (iout,*) '*******i',i,' iti1',iti
3409 cd        write (iout,*) 'b1',b1(:,i-2)
3410 cd        write (iout,*) 'b2',b2(:,i-2)
3411 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3412         if (i .gt. iatel_s+2) then
3413           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3414           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
3415           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3416           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3417           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3418           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3419           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3420         else
3421           do k=1,2
3422             Ub2(k,i-2)=0.0d0
3423             Ctobr(k,i-2)=0.0d0
3424             Dtobr2(k,i-2)=0.0d0
3425             do l=1,2
3426               EUg(l,k,i-2)=0.0d0
3427               CUg(l,k,i-2)=0.0d0
3428               DUg(l,k,i-2)=0.0d0
3429               DtUg2(l,k,i-2)=0.0d0
3430             enddo
3431           enddo
3432         endif
3433         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3434         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
3435         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3436         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3437         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3438         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3439         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3440         do k=1,2
3441           muder(k,i-2)=Ub2der(k,i-2)
3442         enddo
3443         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3444           iti1 = itortyp(itype(i-1))
3445         else
3446           iti1=ntortyp+1
3447         endif
3448         do k=1,2
3449           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3450         enddo
3451 C Vectors and matrices dependent on a single virtual-bond dihedral.
3452         call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3453         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3454         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3455         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3456         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3457         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3458         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3459         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3460         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3461 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
3462 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
3463       enddo
3464 C Matrices dependent on two consecutive virtual-bond dihedrals.
3465 C The order of matrices is from left to right.
3466       do i=2,nres-1
3467         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3468         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3469         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3470         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3471         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3472         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3473         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3474         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3475       enddo
3476 cd      do i=1,nres
3477 cd        iti = itortyp(itype(i))
3478 cd        write (iout,*) i
3479 cd        do j=1,2
3480 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3481 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3482 cd        enddo
3483 cd      enddo
3484       return
3485       end
3486 C--------------------------------------------------------------------------
3487       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3488 C
3489 C This subroutine calculates the average interaction energy and its gradient
3490 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3491 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3492 C The potential depends both on the distance of peptide-group centers and on
3493 C the orientation of the CA-CA virtual bonds.
3494 C
3495       implicit real*8 (a-h,o-z)
3496       include 'DIMENSIONS'
3497       include 'DIMENSIONS.ZSCOPT'
3498       include 'COMMON.CONTROL'
3499       include 'COMMON.IOUNITS'
3500       include 'COMMON.GEO'
3501       include 'COMMON.VAR'
3502       include 'COMMON.LOCAL'
3503       include 'COMMON.CHAIN'
3504       include 'COMMON.DERIV'
3505       include 'COMMON.INTERACT'
3506       include 'COMMON.CONTACTS'
3507       include 'COMMON.TORSION'
3508       include 'COMMON.VECTORS'
3509       include 'COMMON.FFIELD'
3510       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3511      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3512       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3513      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3514       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
3515 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3516       double precision scal_el /0.5d0/
3517 C 12/13/98
3518 C 13-go grudnia roku pamietnego...
3519       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3520      &                   0.0d0,1.0d0,0.0d0,
3521      &                   0.0d0,0.0d0,1.0d0/
3522 cd      write(iout,*) 'In EELEC'
3523 cd      do i=1,nloctyp
3524 cd        write(iout,*) 'Type',i
3525 cd        write(iout,*) 'B1',B1(:,i)
3526 cd        write(iout,*) 'B2',B2(:,i)
3527 cd        write(iout,*) 'CC',CC(:,:,i)
3528 cd        write(iout,*) 'DD',DD(:,:,i)
3529 cd        write(iout,*) 'EE',EE(:,:,i)
3530 cd      enddo
3531 cd      call check_vecgrad
3532 cd      stop
3533       if (icheckgrad.eq.1) then
3534         do i=1,nres-1
3535           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3536           do k=1,3
3537             dc_norm(k,i)=dc(k,i)*fac
3538           enddo
3539 c          write (iout,*) 'i',i,' fac',fac
3540         enddo
3541       endif
3542       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3543      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3544      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3545 cd      if (wel_loc.gt.0.0d0) then
3546         if (icheckgrad.eq.1) then
3547         call vec_and_deriv_test
3548         else
3549         call vec_and_deriv
3550         endif
3551         call set_matrices
3552       endif
3553 cd      do i=1,nres-1
3554 cd        write (iout,*) 'i=',i
3555 cd        do k=1,3
3556 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3557 cd        enddo
3558 cd        do k=1,3
3559 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3560 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3561 cd        enddo
3562 cd      enddo
3563       num_conti_hb=0
3564       ees=0.0D0
3565       evdw1=0.0D0
3566       eel_loc=0.0d0
3567       eello_turn3=0.0d0
3568       eello_turn4=0.0d0
3569       ind=0
3570       do i=1,nres
3571         num_cont_hb(i)=0
3572       enddo
3573 cd      print '(a)','Enter EELEC'
3574 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3575       do i=1,nres
3576         gel_loc_loc(i)=0.0d0
3577         gcorr_loc(i)=0.0d0
3578       enddo
3579       do i=iatel_s,iatel_e
3580         if (itel(i).eq.0) goto 1215
3581         dxi=dc(1,i)
3582         dyi=dc(2,i)
3583         dzi=dc(3,i)
3584         dx_normi=dc_norm(1,i)
3585         dy_normi=dc_norm(2,i)
3586         dz_normi=dc_norm(3,i)
3587         xmedi=c(1,i)+0.5d0*dxi
3588         ymedi=c(2,i)+0.5d0*dyi
3589         zmedi=c(3,i)+0.5d0*dzi
3590         num_conti=0
3591 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3592         do j=ielstart(i),ielend(i)
3593           if (itel(j).eq.0) goto 1216
3594           ind=ind+1
3595           iteli=itel(i)
3596           itelj=itel(j)
3597           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3598           aaa=app(iteli,itelj)
3599           bbb=bpp(iteli,itelj)
3600 C Diagnostics only!!!
3601 c         aaa=0.0D0
3602 c         bbb=0.0D0
3603 c         ael6i=0.0D0
3604 c         ael3i=0.0D0
3605 C End diagnostics
3606           ael6i=ael6(iteli,itelj)
3607           ael3i=ael3(iteli,itelj)
3608           dxj=dc(1,j)
3609           dyj=dc(2,j)
3610           dzj=dc(3,j)
3611           dx_normj=dc_norm(1,j)
3612           dy_normj=dc_norm(2,j)
3613           dz_normj=dc_norm(3,j)
3614           xj=c(1,j)+0.5D0*dxj-xmedi
3615           yj=c(2,j)+0.5D0*dyj-ymedi
3616           zj=c(3,j)+0.5D0*dzj-zmedi
3617           rij=xj*xj+yj*yj+zj*zj
3618           rrmij=1.0D0/rij
3619           rij=dsqrt(rij)
3620           rmij=1.0D0/rij
3621           r3ij=rrmij*rmij
3622           r6ij=r3ij*r3ij
3623           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3624           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3625           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3626           fac=cosa-3.0D0*cosb*cosg
3627           ev1=aaa*r6ij*r6ij
3628 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3629           if (j.eq.i+2) ev1=scal_el*ev1
3630           ev2=bbb*r6ij
3631           fac3=ael6i*r6ij
3632           fac4=ael3i*r3ij
3633           evdwij=ev1+ev2
3634           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3635           el2=fac4*fac
3636           eesij=el1+el2
3637 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
3638 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3639           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3640           ees=ees+eesij
3641           evdw1=evdw1+evdwij
3642 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3643 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3644 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3645 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3646 C
3647 C Calculate contributions to the Cartesian gradient.
3648 C
3649 #ifdef SPLITELE
3650           facvdw=-6*rrmij*(ev1+evdwij)
3651           facel=-3*rrmij*(el1+eesij)
3652           fac1=fac
3653           erij(1)=xj*rmij
3654           erij(2)=yj*rmij
3655           erij(3)=zj*rmij
3656           if (calc_grad) then
3657 *
3658 * Radial derivatives. First process both termini of the fragment (i,j)
3659 *
3660           ggg(1)=facel*xj
3661           ggg(2)=facel*yj
3662           ggg(3)=facel*zj
3663           do k=1,3
3664             ghalf=0.5D0*ggg(k)
3665             gelc(k,i)=gelc(k,i)+ghalf
3666             gelc(k,j)=gelc(k,j)+ghalf
3667           enddo
3668 *
3669 * Loop over residues i+1 thru j-1.
3670 *
3671           do k=i+1,j-1
3672             do l=1,3
3673               gelc(l,k)=gelc(l,k)+ggg(l)
3674             enddo
3675           enddo
3676           ggg(1)=facvdw*xj
3677           ggg(2)=facvdw*yj
3678           ggg(3)=facvdw*zj
3679           do k=1,3
3680             ghalf=0.5D0*ggg(k)
3681             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3682             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3683           enddo
3684 *
3685 * Loop over residues i+1 thru j-1.
3686 *
3687           do k=i+1,j-1
3688             do l=1,3
3689               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3690             enddo
3691           enddo
3692 #else
3693           facvdw=ev1+evdwij
3694           facel=el1+eesij
3695           fac1=fac
3696           fac=-3*rrmij*(facvdw+facvdw+facel)
3697           erij(1)=xj*rmij
3698           erij(2)=yj*rmij
3699           erij(3)=zj*rmij
3700           if (calc_grad) then
3701 *
3702 * Radial derivatives. First process both termini of the fragment (i,j)
3703 *
3704           ggg(1)=fac*xj
3705           ggg(2)=fac*yj
3706           ggg(3)=fac*zj
3707           do k=1,3
3708             ghalf=0.5D0*ggg(k)
3709             gelc(k,i)=gelc(k,i)+ghalf
3710             gelc(k,j)=gelc(k,j)+ghalf
3711           enddo
3712 *
3713 * Loop over residues i+1 thru j-1.
3714 *
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 * Angular part
3723 *
3724           ecosa=2.0D0*fac3*fac1+fac4
3725           fac4=-3.0D0*fac4
3726           fac3=-6.0D0*fac3
3727           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3728           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3729           do k=1,3
3730             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3731             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3732           enddo
3733 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3734 cd   &          (dcosg(k),k=1,3)
3735           do k=1,3
3736             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3737           enddo
3738           do k=1,3
3739             ghalf=0.5D0*ggg(k)
3740             gelc(k,i)=gelc(k,i)+ghalf
3741      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3742      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3743             gelc(k,j)=gelc(k,j)+ghalf
3744      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3745      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3746           enddo
3747           do k=i+1,j-1
3748             do l=1,3
3749               gelc(l,k)=gelc(l,k)+ggg(l)
3750             enddo
3751           enddo
3752           endif
3753
3754           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3755      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3756      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3757 C
3758 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3759 C   energy of a peptide unit is assumed in the form of a second-order
3760 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3761 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3762 C   are computed for EVERY pair of non-contiguous peptide groups.
3763 C
3764           if (j.lt.nres-1) then
3765             j1=j+1
3766             j2=j-1
3767           else
3768             j1=j-1
3769             j2=j-2
3770           endif
3771           kkk=0
3772           do k=1,2
3773             do l=1,2
3774               kkk=kkk+1
3775               muij(kkk)=mu(k,i)*mu(l,j)
3776             enddo
3777           enddo
3778 cd         write (iout,*) 'EELEC: i',i,' j',j
3779 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3780 cd          write(iout,*) 'muij',muij
3781           ury=scalar(uy(1,i),erij)
3782           urz=scalar(uz(1,i),erij)
3783           vry=scalar(uy(1,j),erij)
3784           vrz=scalar(uz(1,j),erij)
3785           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3786           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3787           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3788           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3789 C For diagnostics only
3790 cd          a22=1.0d0
3791 cd          a23=1.0d0
3792 cd          a32=1.0d0
3793 cd          a33=1.0d0
3794           fac=dsqrt(-ael6i)*r3ij
3795 cd          write (2,*) 'fac=',fac
3796 C For diagnostics only
3797 cd          fac=1.0d0
3798           a22=a22*fac
3799           a23=a23*fac
3800           a32=a32*fac
3801           a33=a33*fac
3802 cd          write (iout,'(4i5,4f10.5)')
3803 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3804 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3805 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
3806 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
3807 cd          write (iout,'(4f10.5)')
3808 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3809 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3810 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3811 cd           write (iout,'(2i3,9f10.5/)') i,j,
3812 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3813           if (calc_grad) then
3814 C Derivatives of the elements of A in virtual-bond vectors
3815           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3816 cd          do k=1,3
3817 cd            do l=1,3
3818 cd              erder(k,l)=0.0d0
3819 cd            enddo
3820 cd          enddo
3821           do k=1,3
3822             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3823             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3824             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3825             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3826             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3827             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3828             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3829             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3830             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3831             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3832             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3833             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3834           enddo
3835 cd          do k=1,3
3836 cd            do l=1,3
3837 cd              uryg(k,l)=0.0d0
3838 cd              urzg(k,l)=0.0d0
3839 cd              vryg(k,l)=0.0d0
3840 cd              vrzg(k,l)=0.0d0
3841 cd            enddo
3842 cd          enddo
3843 C Compute radial contributions to the gradient
3844           facr=-3.0d0*rrmij
3845           a22der=a22*facr
3846           a23der=a23*facr
3847           a32der=a32*facr
3848           a33der=a33*facr
3849 cd          a22der=0.0d0
3850 cd          a23der=0.0d0
3851 cd          a32der=0.0d0
3852 cd          a33der=0.0d0
3853           agg(1,1)=a22der*xj
3854           agg(2,1)=a22der*yj
3855           agg(3,1)=a22der*zj
3856           agg(1,2)=a23der*xj
3857           agg(2,2)=a23der*yj
3858           agg(3,2)=a23der*zj
3859           agg(1,3)=a32der*xj
3860           agg(2,3)=a32der*yj
3861           agg(3,3)=a32der*zj
3862           agg(1,4)=a33der*xj
3863           agg(2,4)=a33der*yj
3864           agg(3,4)=a33der*zj
3865 C Add the contributions coming from er
3866           fac3=-3.0d0*fac
3867           do k=1,3
3868             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3869             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3870             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3871             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3872           enddo
3873           do k=1,3
3874 C Derivatives in DC(i)
3875             ghalf1=0.5d0*agg(k,1)
3876             ghalf2=0.5d0*agg(k,2)
3877             ghalf3=0.5d0*agg(k,3)
3878             ghalf4=0.5d0*agg(k,4)
3879             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3880      &      -3.0d0*uryg(k,2)*vry)+ghalf1
3881             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3882      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
3883             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3884      &      -3.0d0*urzg(k,2)*vry)+ghalf3
3885             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3886      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
3887 C Derivatives in DC(i+1)
3888             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3889      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
3890             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3891      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
3892             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3893      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
3894             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3895      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
3896 C Derivatives in DC(j)
3897             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3898      &      -3.0d0*vryg(k,2)*ury)+ghalf1
3899             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3900      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
3901             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3902      &      -3.0d0*vryg(k,2)*urz)+ghalf3
3903             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3904      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
3905 C Derivatives in DC(j+1) or DC(nres-1)
3906             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3907      &      -3.0d0*vryg(k,3)*ury)
3908             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3909      &      -3.0d0*vrzg(k,3)*ury)
3910             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3911      &      -3.0d0*vryg(k,3)*urz)
3912             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3913      &      -3.0d0*vrzg(k,3)*urz)
3914 cd            aggi(k,1)=ghalf1
3915 cd            aggi(k,2)=ghalf2
3916 cd            aggi(k,3)=ghalf3
3917 cd            aggi(k,4)=ghalf4
3918 C Derivatives in DC(i+1)
3919 cd            aggi1(k,1)=agg(k,1)
3920 cd            aggi1(k,2)=agg(k,2)
3921 cd            aggi1(k,3)=agg(k,3)
3922 cd            aggi1(k,4)=agg(k,4)
3923 C Derivatives in DC(j)
3924 cd            aggj(k,1)=ghalf1
3925 cd            aggj(k,2)=ghalf2
3926 cd            aggj(k,3)=ghalf3
3927 cd            aggj(k,4)=ghalf4
3928 C Derivatives in DC(j+1)
3929 cd            aggj1(k,1)=0.0d0
3930 cd            aggj1(k,2)=0.0d0
3931 cd            aggj1(k,3)=0.0d0
3932 cd            aggj1(k,4)=0.0d0
3933             if (j.eq.nres-1 .and. i.lt.j-2) then
3934               do l=1,4
3935                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
3936 cd                aggj1(k,l)=agg(k,l)
3937               enddo
3938             endif
3939           enddo
3940           endif
3941 c          goto 11111
3942 C Check the loc-el terms by numerical integration
3943           acipa(1,1)=a22
3944           acipa(1,2)=a23
3945           acipa(2,1)=a32
3946           acipa(2,2)=a33
3947           a22=-a22
3948           a23=-a23
3949           do l=1,2
3950             do k=1,3
3951               agg(k,l)=-agg(k,l)
3952               aggi(k,l)=-aggi(k,l)
3953               aggi1(k,l)=-aggi1(k,l)
3954               aggj(k,l)=-aggj(k,l)
3955               aggj1(k,l)=-aggj1(k,l)
3956             enddo
3957           enddo
3958           if (j.lt.nres-1) then
3959             a22=-a22
3960             a32=-a32
3961             do l=1,3,2
3962               do k=1,3
3963                 agg(k,l)=-agg(k,l)
3964                 aggi(k,l)=-aggi(k,l)
3965                 aggi1(k,l)=-aggi1(k,l)
3966                 aggj(k,l)=-aggj(k,l)
3967                 aggj1(k,l)=-aggj1(k,l)
3968               enddo
3969             enddo
3970           else
3971             a22=-a22
3972             a23=-a23
3973             a32=-a32
3974             a33=-a33
3975             do l=1,4
3976               do k=1,3
3977                 agg(k,l)=-agg(k,l)
3978                 aggi(k,l)=-aggi(k,l)
3979                 aggi1(k,l)=-aggi1(k,l)
3980                 aggj(k,l)=-aggj(k,l)
3981                 aggj1(k,l)=-aggj1(k,l)
3982               enddo
3983             enddo
3984           endif
3985           ENDIF ! WCORR
3986 11111     continue
3987           IF (wel_loc.gt.0.0d0) THEN
3988 C Contribution to the local-electrostatic energy coming from the i-j pair
3989           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3990      &     +a33*muij(4)
3991 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3992 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3993           eel_loc=eel_loc+eel_loc_ij
3994 C Partial derivatives in virtual-bond dihedral angles gamma
3995           if (calc_grad) then
3996           if (i.gt.1)
3997      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3998      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3999      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
4000           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4001      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4002      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
4003 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
4004 cd          write(iout,*) 'agg  ',agg
4005 cd          write(iout,*) 'aggi ',aggi
4006 cd          write(iout,*) 'aggi1',aggi1
4007 cd          write(iout,*) 'aggj ',aggj
4008 cd          write(iout,*) 'aggj1',aggj1
4009
4010 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4011           do l=1,3
4012             ggg(l)=agg(l,1)*muij(1)+
4013      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
4014           enddo
4015           do k=i+2,j2
4016             do l=1,3
4017               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4018             enddo
4019           enddo
4020 C Remaining derivatives of eello
4021           do l=1,3
4022             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
4023      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
4024             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
4025      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
4026             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
4027      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
4028             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
4029      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
4030           enddo
4031           endif
4032           ENDIF
4033           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4034 C Contributions from turns
4035             a_temp(1,1)=a22
4036             a_temp(1,2)=a23
4037             a_temp(2,1)=a32
4038             a_temp(2,2)=a33
4039             call eturn34(i,j,eello_turn3,eello_turn4)
4040           endif
4041 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4042           if (j.gt.i+1 .and. num_conti.le.maxconts) then
4043 C
4044 C Calculate the contact function. The ith column of the array JCONT will
4045 C contain the numbers of atoms that make contacts with the atom I (of numbers
4046 C greater than I). The arrays FACONT and GACONT will contain the values of
4047 C the contact function and its derivative.
4048 c           r0ij=1.02D0*rpp(iteli,itelj)
4049 c           r0ij=1.11D0*rpp(iteli,itelj)
4050             r0ij=2.20D0*rpp(iteli,itelj)
4051 c           r0ij=1.55D0*rpp(iteli,itelj)
4052             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4053             if (fcont.gt.0.0D0) then
4054               num_conti=num_conti+1
4055               if (num_conti.gt.maxconts) then
4056                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4057      &                         ' will skip next contacts for this conf.'
4058               else
4059                 jcont_hb(num_conti,i)=j
4060                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4061      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4062 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4063 C  terms.
4064                 d_cont(num_conti,i)=rij
4065 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4066 C     --- Electrostatic-interaction matrix ---
4067                 a_chuj(1,1,num_conti,i)=a22
4068                 a_chuj(1,2,num_conti,i)=a23
4069                 a_chuj(2,1,num_conti,i)=a32
4070                 a_chuj(2,2,num_conti,i)=a33
4071 C     --- Gradient of rij
4072                 do kkk=1,3
4073                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4074                 enddo
4075 c             if (i.eq.1) then
4076 c                a_chuj(1,1,num_conti,i)=-0.61d0
4077 c                a_chuj(1,2,num_conti,i)= 0.4d0
4078 c                a_chuj(2,1,num_conti,i)= 0.65d0
4079 c                a_chuj(2,2,num_conti,i)= 0.50d0
4080 c             else if (i.eq.2) then
4081 c                a_chuj(1,1,num_conti,i)= 0.0d0
4082 c                a_chuj(1,2,num_conti,i)= 0.0d0
4083 c                a_chuj(2,1,num_conti,i)= 0.0d0
4084 c                a_chuj(2,2,num_conti,i)= 0.0d0
4085 c             endif
4086 C     --- and its gradients
4087 cd                write (iout,*) 'i',i,' j',j
4088 cd                do kkk=1,3
4089 cd                write (iout,*) 'iii 1 kkk',kkk
4090 cd                write (iout,*) agg(kkk,:)
4091 cd                enddo
4092 cd                do kkk=1,3
4093 cd                write (iout,*) 'iii 2 kkk',kkk
4094 cd                write (iout,*) aggi(kkk,:)
4095 cd                enddo
4096 cd                do kkk=1,3
4097 cd                write (iout,*) 'iii 3 kkk',kkk
4098 cd                write (iout,*) aggi1(kkk,:)
4099 cd                enddo
4100 cd                do kkk=1,3
4101 cd                write (iout,*) 'iii 4 kkk',kkk
4102 cd                write (iout,*) aggj(kkk,:)
4103 cd                enddo
4104 cd                do kkk=1,3
4105 cd                write (iout,*) 'iii 5 kkk',kkk
4106 cd                write (iout,*) aggj1(kkk,:)
4107 cd                enddo
4108                 kkll=0
4109                 do k=1,2
4110                   do l=1,2
4111                     kkll=kkll+1
4112                     do m=1,3
4113                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4114                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4115                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4116                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4117                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4118 c                      do mm=1,5
4119 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
4120 c                      enddo
4121                     enddo
4122                   enddo
4123                 enddo
4124                 ENDIF
4125                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4126 C Calculate contact energies
4127                 cosa4=4.0D0*cosa
4128                 wij=cosa-3.0D0*cosb*cosg
4129                 cosbg1=cosb+cosg
4130                 cosbg2=cosb-cosg
4131 c               fac3=dsqrt(-ael6i)/r0ij**3
4132                 fac3=dsqrt(-ael6i)*r3ij
4133                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4134                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4135 c               ees0mij=0.0D0
4136                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4137                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4138 C Diagnostics. Comment out or remove after debugging!
4139 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4140 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4141 c               ees0m(num_conti,i)=0.0D0
4142 C End diagnostics.
4143 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4144 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4145                 facont_hb(num_conti,i)=fcont
4146                 if (calc_grad) then
4147 C Angular derivatives of the contact function
4148                 ees0pij1=fac3/ees0pij
4149                 ees0mij1=fac3/ees0mij
4150                 fac3p=-3.0D0*fac3*rrmij
4151                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4152                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4153 c               ees0mij1=0.0D0
4154                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4155                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4156                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4157                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4158                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4159                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4160                 ecosap=ecosa1+ecosa2
4161                 ecosbp=ecosb1+ecosb2
4162                 ecosgp=ecosg1+ecosg2
4163                 ecosam=ecosa1-ecosa2
4164                 ecosbm=ecosb1-ecosb2
4165                 ecosgm=ecosg1-ecosg2
4166 C Diagnostics
4167 c               ecosap=ecosa1
4168 c               ecosbp=ecosb1
4169 c               ecosgp=ecosg1
4170 c               ecosam=0.0D0
4171 c               ecosbm=0.0D0
4172 c               ecosgm=0.0D0
4173 C End diagnostics
4174                 fprimcont=fprimcont/rij
4175 cd              facont_hb(num_conti,i)=1.0D0
4176 C Following line is for diagnostics.
4177 cd              fprimcont=0.0D0
4178                 do k=1,3
4179                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4180                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4181                 enddo
4182                 do k=1,3
4183                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4184                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4185                 enddo
4186                 gggp(1)=gggp(1)+ees0pijp*xj
4187                 gggp(2)=gggp(2)+ees0pijp*yj
4188                 gggp(3)=gggp(3)+ees0pijp*zj
4189                 gggm(1)=gggm(1)+ees0mijp*xj
4190                 gggm(2)=gggm(2)+ees0mijp*yj
4191                 gggm(3)=gggm(3)+ees0mijp*zj
4192 C Derivatives due to the contact function
4193                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4194                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4195                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4196                 do k=1,3
4197                   ghalfp=0.5D0*gggp(k)
4198                   ghalfm=0.5D0*gggm(k)
4199                   gacontp_hb1(k,num_conti,i)=ghalfp
4200      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4201      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4202                   gacontp_hb2(k,num_conti,i)=ghalfp
4203      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4204      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4205                   gacontp_hb3(k,num_conti,i)=gggp(k)
4206                   gacontm_hb1(k,num_conti,i)=ghalfm
4207      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4208      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4209                   gacontm_hb2(k,num_conti,i)=ghalfm
4210      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4211      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4212                   gacontm_hb3(k,num_conti,i)=gggm(k)
4213                 enddo
4214                 endif
4215 C Diagnostics. Comment out or remove after debugging!
4216 cdiag           do k=1,3
4217 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4218 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4219 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4220 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4221 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4222 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4223 cdiag           enddo
4224               ENDIF ! wcorr
4225               endif  ! num_conti.le.maxconts
4226             endif  ! fcont.gt.0
4227           endif    ! j.gt.i+1
4228  1216     continue
4229         enddo ! j
4230         num_cont_hb(i)=num_conti
4231  1215   continue
4232       enddo   ! i
4233 cd      do i=1,nres
4234 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
4235 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
4236 cd      enddo
4237 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
4238 ccc      eel_loc=eel_loc+eello_turn3
4239       return
4240       end
4241 C-----------------------------------------------------------------------------
4242       subroutine eturn34(i,j,eello_turn3,eello_turn4)
4243 C Third- and fourth-order contributions from turns
4244       implicit real*8 (a-h,o-z)
4245       include 'DIMENSIONS'
4246       include 'DIMENSIONS.ZSCOPT'
4247       include 'COMMON.IOUNITS'
4248       include 'COMMON.GEO'
4249       include 'COMMON.VAR'
4250       include 'COMMON.LOCAL'
4251       include 'COMMON.CHAIN'
4252       include 'COMMON.DERIV'
4253       include 'COMMON.INTERACT'
4254       include 'COMMON.CONTACTS'
4255       include 'COMMON.TORSION'
4256       include 'COMMON.VECTORS'
4257       include 'COMMON.FFIELD'
4258       dimension ggg(3)
4259       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4260      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4261      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
4262       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4263      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
4264       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
4265       if (j.eq.i+2) then
4266 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4267 C
4268 C               Third-order contributions
4269 C
4270 C                 (i+2)o----(i+3)
4271 C                      | |
4272 C                      | |
4273 C                 (i+1)o----i
4274 C
4275 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4276 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4277         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4278         call transpose2(auxmat(1,1),auxmat1(1,1))
4279         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4280         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4281 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4282 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4283 cd     &    ' eello_turn3_num',4*eello_turn3_num
4284         if (calc_grad) then
4285 C Derivatives in gamma(i)
4286         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4287         call transpose2(auxmat2(1,1),pizda(1,1))
4288         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
4289         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4290 C Derivatives in gamma(i+1)
4291         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4292         call transpose2(auxmat2(1,1),pizda(1,1))
4293         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
4294         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4295      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4296 C Cartesian derivatives
4297         do l=1,3
4298           a_temp(1,1)=aggi(l,1)
4299           a_temp(1,2)=aggi(l,2)
4300           a_temp(2,1)=aggi(l,3)
4301           a_temp(2,2)=aggi(l,4)
4302           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4303           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4304      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4305           a_temp(1,1)=aggi1(l,1)
4306           a_temp(1,2)=aggi1(l,2)
4307           a_temp(2,1)=aggi1(l,3)
4308           a_temp(2,2)=aggi1(l,4)
4309           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4310           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4311      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4312           a_temp(1,1)=aggj(l,1)
4313           a_temp(1,2)=aggj(l,2)
4314           a_temp(2,1)=aggj(l,3)
4315           a_temp(2,2)=aggj(l,4)
4316           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4317           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4318      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4319           a_temp(1,1)=aggj1(l,1)
4320           a_temp(1,2)=aggj1(l,2)
4321           a_temp(2,1)=aggj1(l,3)
4322           a_temp(2,2)=aggj1(l,4)
4323           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4324           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4325      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4326         enddo
4327         endif
4328       else if (j.eq.i+3) then
4329 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4330 C
4331 C               Fourth-order contributions
4332 C
4333 C                 (i+3)o----(i+4)
4334 C                     /  |
4335 C               (i+2)o   |
4336 C                     \  |
4337 C                 (i+1)o----i
4338 C
4339 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4340 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4341         iti1=itortyp(itype(i+1))
4342         iti2=itortyp(itype(i+2))
4343         iti3=itortyp(itype(i+3))
4344         call transpose2(EUg(1,1,i+1),e1t(1,1))
4345         call transpose2(Eug(1,1,i+2),e2t(1,1))
4346         call transpose2(Eug(1,1,i+3),e3t(1,1))
4347         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4348         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4349         s1=scalar2(b1(1,i+2),auxvec(1))
4350         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4351         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4352         s2=scalar2(b1(1,i+1),auxvec(1))
4353         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4354         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4355         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4356         eello_turn4=eello_turn4-(s1+s2+s3)
4357 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4358 cd     &    ' eello_turn4_num',8*eello_turn4_num
4359 C Derivatives in gamma(i)
4360         if (calc_grad) then
4361         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4362         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4363         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4364         s1=scalar2(b1(1,i+2),auxvec(1))
4365         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4366         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4367         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4368 C Derivatives in gamma(i+1)
4369         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4370         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4371         s2=scalar2(b1(1,i+1),auxvec(1))
4372         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4373         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4374         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4375         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4376 C Derivatives in gamma(i+2)
4377         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4378         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4379         s1=scalar2(b1(1,i+2),auxvec(1))
4380         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4381         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4382         s2=scalar2(b1(1,i+1),auxvec(1))
4383         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
4384         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4385         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4386         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4387 C Cartesian derivatives
4388 C Derivatives of this turn contributions in DC(i+2)
4389         if (j.lt.nres-1) then
4390           do l=1,3
4391             a_temp(1,1)=agg(l,1)
4392             a_temp(1,2)=agg(l,2)
4393             a_temp(2,1)=agg(l,3)
4394             a_temp(2,2)=agg(l,4)
4395             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4396             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4397             s1=scalar2(b1(1,i+2),auxvec(1))
4398             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4399             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4400             s2=scalar2(b1(1,i+1),auxvec(1))
4401             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4402             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4403             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4404             ggg(l)=-(s1+s2+s3)
4405             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4406           enddo
4407         endif
4408 C Remaining derivatives of this turn contribution
4409         do l=1,3
4410           a_temp(1,1)=aggi(l,1)
4411           a_temp(1,2)=aggi(l,2)
4412           a_temp(2,1)=aggi(l,3)
4413           a_temp(2,2)=aggi(l,4)
4414           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4415           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4416           s1=scalar2(b1(1,i+2),auxvec(1))
4417           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4418           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4419           s2=scalar2(b1(1,i+1),auxvec(1))
4420           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4421           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4422           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4423           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4424           a_temp(1,1)=aggi1(l,1)
4425           a_temp(1,2)=aggi1(l,2)
4426           a_temp(2,1)=aggi1(l,3)
4427           a_temp(2,2)=aggi1(l,4)
4428           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4429           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4430           s1=scalar2(b1(1,i+2),auxvec(1))
4431           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4432           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4433           s2=scalar2(b1(1,i+1),auxvec(1))
4434           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4435           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4436           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4437           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4438           a_temp(1,1)=aggj(l,1)
4439           a_temp(1,2)=aggj(l,2)
4440           a_temp(2,1)=aggj(l,3)
4441           a_temp(2,2)=aggj(l,4)
4442           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4443           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4444           s1=scalar2(b1(1,i+2),auxvec(1))
4445           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4446           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4447           s2=scalar2(b1(1,i+1),auxvec(1))
4448           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4449           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4450           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4451           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4452           a_temp(1,1)=aggj1(l,1)
4453           a_temp(1,2)=aggj1(l,2)
4454           a_temp(2,1)=aggj1(l,3)
4455           a_temp(2,2)=aggj1(l,4)
4456           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4457           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4458           s1=scalar2(b1(1,i+2),auxvec(1))
4459           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4460           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4461           s2=scalar2(b1(1,i+1),auxvec(1))
4462           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4463           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4464           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4465           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4466         enddo
4467         endif
4468       endif
4469       return
4470       end
4471 C-----------------------------------------------------------------------------
4472       subroutine vecpr(u,v,w)
4473       implicit real*8(a-h,o-z)
4474       dimension u(3),v(3),w(3)
4475       w(1)=u(2)*v(3)-u(3)*v(2)
4476       w(2)=-u(1)*v(3)+u(3)*v(1)
4477       w(3)=u(1)*v(2)-u(2)*v(1)
4478       return
4479       end
4480 C-----------------------------------------------------------------------------
4481       subroutine unormderiv(u,ugrad,unorm,ungrad)
4482 C This subroutine computes the derivatives of a normalized vector u, given
4483 C the derivatives computed without normalization conditions, ugrad. Returns
4484 C ungrad.
4485       implicit none
4486       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4487       double precision vec(3)
4488       double precision scalar
4489       integer i,j
4490 c      write (2,*) 'ugrad',ugrad
4491 c      write (2,*) 'u',u
4492       do i=1,3
4493         vec(i)=scalar(ugrad(1,i),u(1))
4494       enddo
4495 c      write (2,*) 'vec',vec
4496       do i=1,3
4497         do j=1,3
4498           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4499         enddo
4500       enddo
4501 c      write (2,*) 'ungrad',ungrad
4502       return
4503       end
4504 C-----------------------------------------------------------------------------
4505       subroutine escp(evdw2,evdw2_14)
4506 C
4507 C This subroutine calculates the excluded-volume interaction energy between
4508 C peptide-group centers and side chains and its gradient in virtual-bond and
4509 C side-chain vectors.
4510 C
4511       implicit real*8 (a-h,o-z)
4512       include 'DIMENSIONS'
4513       include 'DIMENSIONS.ZSCOPT'
4514       include 'COMMON.GEO'
4515       include 'COMMON.VAR'
4516       include 'COMMON.LOCAL'
4517       include 'COMMON.CHAIN'
4518       include 'COMMON.DERIV'
4519       include 'COMMON.INTERACT'
4520       include 'COMMON.FFIELD'
4521       include 'COMMON.IOUNITS'
4522       dimension ggg(3)
4523       evdw2=0.0D0
4524       evdw2_14=0.0d0
4525 cd    print '(a)','Enter ESCP'
4526 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
4527 c     &  ' scal14',scal14
4528       do i=iatscp_s,iatscp_e
4529         iteli=itel(i)
4530 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
4531 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
4532         if (iteli.eq.0) goto 1225
4533         xi=0.5D0*(c(1,i)+c(1,i+1))
4534         yi=0.5D0*(c(2,i)+c(2,i+1))
4535         zi=0.5D0*(c(3,i)+c(3,i+1))
4536
4537         do iint=1,nscp_gr(i)
4538
4539         do j=iscpstart(i,iint),iscpend(i,iint)
4540           itypj=itype(j)
4541 C Uncomment following three lines for SC-p interactions
4542 c         xj=c(1,nres+j)-xi
4543 c         yj=c(2,nres+j)-yi
4544 c         zj=c(3,nres+j)-zi
4545 C Uncomment following three lines for Ca-p interactions
4546           xj=c(1,j)-xi
4547           yj=c(2,j)-yi
4548           zj=c(3,j)-zi
4549           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4550           fac=rrij**expon2
4551           e1=fac*fac*aad(itypj,iteli)
4552           e2=fac*bad(itypj,iteli)
4553           if (iabs(j-i) .le. 2) then
4554             e1=scal14*e1
4555             e2=scal14*e2
4556             evdw2_14=evdw2_14+e1+e2
4557           endif
4558           evdwij=e1+e2
4559 c          write (iout,*) i,j,evdwij
4560           evdw2=evdw2+evdwij
4561           if (calc_grad) then
4562 C
4563 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4564 C
4565           fac=-(evdwij+e1)*rrij
4566           ggg(1)=xj*fac
4567           ggg(2)=yj*fac
4568           ggg(3)=zj*fac
4569           if (j.lt.i) then
4570 cd          write (iout,*) 'j<i'
4571 C Uncomment following three lines for SC-p interactions
4572 c           do k=1,3
4573 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4574 c           enddo
4575           else
4576 cd          write (iout,*) 'j>i'
4577             do k=1,3
4578               ggg(k)=-ggg(k)
4579 C Uncomment following line for SC-p interactions
4580 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4581             enddo
4582           endif
4583           do k=1,3
4584             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4585           enddo
4586           kstart=min0(i+1,j)
4587           kend=max0(i-1,j-1)
4588 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4589 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4590           do k=kstart,kend
4591             do l=1,3
4592               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4593             enddo
4594           enddo
4595           endif
4596         enddo
4597         enddo ! iint
4598  1225   continue
4599       enddo ! i
4600       do i=1,nct
4601         do j=1,3
4602           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4603           gradx_scp(j,i)=expon*gradx_scp(j,i)
4604         enddo
4605       enddo
4606 C******************************************************************************
4607 C
4608 C                              N O T E !!!
4609 C
4610 C To save time the factor EXPON has been extracted from ALL components
4611 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4612 C use!
4613 C
4614 C******************************************************************************
4615       return
4616       end
4617 C--------------------------------------------------------------------------
4618       subroutine edis(ehpb)
4619 C
4620 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4621 C
4622       implicit real*8 (a-h,o-z)
4623       include 'DIMENSIONS'
4624       include 'COMMON.SBRIDGE'
4625       include 'COMMON.CHAIN'
4626       include 'COMMON.DERIV'
4627       include 'COMMON.VAR'
4628       include 'COMMON.INTERACT'
4629       include 'COMMON.IOUNITS'
4630       dimension ggg(3)
4631       ehpb=0.0D0
4632 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4633 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4634       if (link_end.eq.0) return
4635       do i=link_start,link_end
4636 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4637 C CA-CA distance used in regularization of structure.
4638         ii=ihpb(i)
4639         jj=jhpb(i)
4640 C iii and jjj point to the residues for which the distance is assigned.
4641         if (ii.gt.nres) then
4642           iii=ii-nres
4643           jjj=jj-nres
4644         else
4645           iii=ii
4646           jjj=jj
4647         endif
4648 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4649 c     &    dhpb(i),dhpb1(i),forcon(i)
4650 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4651 C    distance and angle dependent SS bond potential.
4652         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4653           call ssbond_ene(iii,jjj,eij)
4654           ehpb=ehpb+2*eij
4655 cd          write (iout,*) "eij",eij
4656         else if (ii.gt.nres .and. jj.gt.nres) then
4657 c Restraints from contact prediction
4658           dd=dist(ii,jj)
4659           if (dhpb1(i).gt.0.0d0) then
4660             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4661             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4662 c            write (iout,*) "beta nmr",
4663 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4664           else
4665             dd=dist(ii,jj)
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,*) "beta reg",dd,waga*rdis*rdis
4672 C
4673 C Evaluate gradient.
4674 C
4675             fac=waga*rdis/dd
4676           endif
4677           do j=1,3
4678             ggg(j)=fac*(c(j,jj)-c(j,ii))
4679           enddo
4680           do j=1,3
4681             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4682             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4683           enddo
4684           do k=1,3
4685             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4686             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4687           enddo
4688         else
4689 C Calculate the distance between the two points and its difference from the
4690 C target distance.
4691           dd=dist(ii,jj)
4692           if (dhpb1(i).gt.0.0d0) then
4693             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4694             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4695 c            write (iout,*) "alph nmr",
4696 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4697           else
4698             rdis=dd-dhpb(i)
4699 C Get the force constant corresponding to this distance.
4700             waga=forcon(i)
4701 C Calculate the contribution to energy.
4702             ehpb=ehpb+waga*rdis*rdis
4703 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4704 C
4705 C Evaluate gradient.
4706 C
4707             fac=waga*rdis/dd
4708           endif
4709 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4710 cd   &   ' waga=',waga,' fac=',fac
4711             do j=1,3
4712               ggg(j)=fac*(c(j,jj)-c(j,ii))
4713             enddo
4714 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4715 C If this is a SC-SC distance, we need to calculate the contributions to the
4716 C Cartesian gradient in the SC vectors (ghpbx).
4717           if (iii.lt.ii) then
4718           do j=1,3
4719             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4720             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4721           enddo
4722           endif
4723           do k=1,3
4724             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4725             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4726           enddo
4727         endif
4728       enddo
4729       ehpb=0.5D0*ehpb
4730       return
4731       end
4732 C--------------------------------------------------------------------------
4733       subroutine ssbond_ene(i,j,eij)
4734 C
4735 C Calculate the distance and angle dependent SS-bond potential energy
4736 C using a free-energy function derived based on RHF/6-31G** ab initio
4737 C calculations of diethyl disulfide.
4738 C
4739 C A. Liwo and U. Kozlowska, 11/24/03
4740 C
4741       implicit real*8 (a-h,o-z)
4742       include 'DIMENSIONS'
4743       include 'DIMENSIONS.ZSCOPT'
4744       include 'COMMON.SBRIDGE'
4745       include 'COMMON.CHAIN'
4746       include 'COMMON.DERIV'
4747       include 'COMMON.LOCAL'
4748       include 'COMMON.INTERACT'
4749       include 'COMMON.VAR'
4750       include 'COMMON.IOUNITS'
4751       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4752       itypi=itype(i)
4753       xi=c(1,nres+i)
4754       yi=c(2,nres+i)
4755       zi=c(3,nres+i)
4756       dxi=dc_norm(1,nres+i)
4757       dyi=dc_norm(2,nres+i)
4758       dzi=dc_norm(3,nres+i)
4759       dsci_inv=dsc_inv(itypi)
4760       itypj=itype(j)
4761       dscj_inv=dsc_inv(itypj)
4762       xj=c(1,nres+j)-xi
4763       yj=c(2,nres+j)-yi
4764       zj=c(3,nres+j)-zi
4765       dxj=dc_norm(1,nres+j)
4766       dyj=dc_norm(2,nres+j)
4767       dzj=dc_norm(3,nres+j)
4768       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4769       rij=dsqrt(rrij)
4770       erij(1)=xj*rij
4771       erij(2)=yj*rij
4772       erij(3)=zj*rij
4773       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4774       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4775       om12=dxi*dxj+dyi*dyj+dzi*dzj
4776       do k=1,3
4777         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4778         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4779       enddo
4780       rij=1.0d0/rij
4781       deltad=rij-d0cm
4782       deltat1=1.0d0-om1
4783       deltat2=1.0d0+om2
4784       deltat12=om2-om1+2.0d0
4785       cosphi=om12-om1*om2
4786       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4787      &  +akct*deltad*deltat12
4788      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4789 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4790 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4791 c     &  " deltat12",deltat12," eij",eij
4792       ed=2*akcm*deltad+akct*deltat12
4793       pom1=akct*deltad
4794       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4795       eom1=-2*akth*deltat1-pom1-om2*pom2
4796       eom2= 2*akth*deltat2+pom1-om1*pom2
4797       eom12=pom2
4798       do k=1,3
4799         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4800       enddo
4801       do k=1,3
4802         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4803      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4804         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4805      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4806       enddo
4807 C
4808 C Calculate the components of the gradient in DC and X
4809 C
4810       do k=i,j-1
4811         do l=1,3
4812           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4813         enddo
4814       enddo
4815       return
4816       end
4817 C--------------------------------------------------------------------------
4818       subroutine ebond(estr)
4819 c
4820 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4821 c
4822       implicit real*8 (a-h,o-z)
4823       include 'DIMENSIONS'
4824       include 'DIMENSIONS.ZSCOPT'
4825       include 'COMMON.LOCAL'
4826       include 'COMMON.GEO'
4827       include 'COMMON.INTERACT'
4828       include 'COMMON.DERIV'
4829       include 'COMMON.VAR'
4830       include 'COMMON.CHAIN'
4831       include 'COMMON.IOUNITS'
4832       include 'COMMON.NAMES'
4833       include 'COMMON.FFIELD'
4834       include 'COMMON.CONTROL'
4835       double precision u(3),ud(3)
4836       estr=0.0d0
4837       do i=nnt+1,nct
4838         diff = vbld(i)-vbldp0
4839 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4840         estr=estr+diff*diff
4841         do j=1,3
4842           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4843         enddo
4844       enddo
4845       estr=0.5d0*AKP*estr
4846 c
4847 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4848 c
4849       do i=nnt,nct
4850         iti=itype(i)
4851         if (iti.ne.10) then
4852           nbi=nbondterm(iti)
4853           if (nbi.eq.1) then
4854             diff=vbld(i+nres)-vbldsc0(1,iti)
4855 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4856 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4857             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4858             do j=1,3
4859               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4860             enddo
4861           else
4862             do j=1,nbi
4863               diff=vbld(i+nres)-vbldsc0(j,iti)
4864               ud(j)=aksc(j,iti)*diff
4865               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4866             enddo
4867             uprod=u(1)
4868             do j=2,nbi
4869               uprod=uprod*u(j)
4870             enddo
4871             usum=0.0d0
4872             usumsqder=0.0d0
4873             do j=1,nbi
4874               uprod1=1.0d0
4875               uprod2=1.0d0
4876               do k=1,nbi
4877                 if (k.ne.j) then
4878                   uprod1=uprod1*u(k)
4879                   uprod2=uprod2*u(k)*u(k)
4880                 endif
4881               enddo
4882               usum=usum+uprod1
4883               usumsqder=usumsqder+ud(j)*uprod2
4884             enddo
4885 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4886 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4887             estr=estr+uprod/usum
4888             do j=1,3
4889              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4890             enddo
4891           endif
4892         endif
4893       enddo
4894       return
4895       end
4896 #ifdef CRYST_THETA
4897 C--------------------------------------------------------------------------
4898       subroutine ebend(etheta)
4899 C
4900 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4901 C angles gamma and its derivatives in consecutive thetas and gammas.
4902 C
4903       implicit real*8 (a-h,o-z)
4904       include 'DIMENSIONS'
4905       include 'DIMENSIONS.ZSCOPT'
4906       include 'COMMON.LOCAL'
4907       include 'COMMON.GEO'
4908       include 'COMMON.INTERACT'
4909       include 'COMMON.DERIV'
4910       include 'COMMON.VAR'
4911       include 'COMMON.CHAIN'
4912       include 'COMMON.IOUNITS'
4913       include 'COMMON.NAMES'
4914       include 'COMMON.FFIELD'
4915       common /calcthet/ term1,term2,termm,diffak,ratak,
4916      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4917      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4918       double precision y(2),z(2)
4919       delta=0.02d0*pi
4920       time11=dexp(-2*time)
4921       time12=1.0d0
4922       etheta=0.0D0
4923 c      write (iout,*) "nres",nres
4924 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4925 c      write (iout,*) ithet_start,ithet_end
4926       do i=ithet_start,ithet_end
4927 C Zero the energy function and its derivative at 0 or pi.
4928         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4929         it=itype(i-1)
4930 c        if (i.gt.ithet_start .and.
4931 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
4932 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
4933 c          phii=phi(i)
4934 c          y(1)=dcos(phii)
4935 c          y(2)=dsin(phii)
4936 c        else
4937 c          y(1)=0.0D0
4938 c          y(2)=0.0D0
4939 c        endif
4940 c        if (i.lt.nres .and. itel(i).ne.0) then
4941 c          phii1=phi(i+1)
4942 c          z(1)=dcos(phii1)
4943 c          z(2)=dsin(phii1)
4944 c        else
4945 c          z(1)=0.0D0
4946 c          z(2)=0.0D0
4947 c        endif
4948         if (i.gt.3) then
4949 #ifdef OSF
4950           phii=phi(i)
4951           icrc=0
4952           call proc_proc(phii,icrc)
4953           if (icrc.eq.1) phii=150.0
4954 #else
4955           phii=phi(i)
4956 #endif
4957           y(1)=dcos(phii)
4958           y(2)=dsin(phii)
4959         else
4960           y(1)=0.0D0
4961           y(2)=0.0D0
4962         endif
4963         if (i.lt.nres) then
4964 #ifdef OSF
4965           phii1=phi(i+1)
4966           icrc=0
4967           call proc_proc(phii1,icrc)
4968           if (icrc.eq.1) phii1=150.0
4969           phii1=pinorm(phii1)
4970           z(1)=cos(phii1)
4971 #else
4972           phii1=phi(i+1)
4973           z(1)=dcos(phii1)
4974 #endif
4975           z(2)=dsin(phii1)
4976         else
4977           z(1)=0.0D0
4978           z(2)=0.0D0
4979         endif
4980 C Calculate the "mean" value of theta from the part of the distribution
4981 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4982 C In following comments this theta will be referred to as t_c.
4983         thet_pred_mean=0.0d0
4984         do k=1,2
4985           athetk=athet(k,it)
4986           bthetk=bthet(k,it)
4987           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4988         enddo
4989 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4990         dthett=thet_pred_mean*ssd
4991         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4992 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4993 C Derivatives of the "mean" values in gamma1 and gamma2.
4994         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4995         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4996         if (theta(i).gt.pi-delta) then
4997           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4998      &         E_tc0)
4999           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5000           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5001           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5002      &        E_theta)
5003           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5004      &        E_tc)
5005         else if (theta(i).lt.delta) then
5006           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5007           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5008           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
5009      &        E_theta)
5010           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5011           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
5012      &        E_tc)
5013         else
5014           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
5015      &        E_theta,E_tc)
5016         endif
5017         etheta=etheta+ethetai
5018 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
5019 c     &    rad2deg*phii,rad2deg*phii1,ethetai
5020         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5021         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5022         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5023  1215   continue
5024       enddo
5025 C Ufff.... We've done all this!!!
5026       return
5027       end
5028 C---------------------------------------------------------------------------
5029       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
5030      &     E_tc)
5031       implicit real*8 (a-h,o-z)
5032       include 'DIMENSIONS'
5033       include 'COMMON.LOCAL'
5034       include 'COMMON.IOUNITS'
5035       common /calcthet/ term1,term2,termm,diffak,ratak,
5036      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5037      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5038 C Calculate the contributions to both Gaussian lobes.
5039 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5040 C The "polynomial part" of the "standard deviation" of this part of
5041 C the distribution.
5042         sig=polthet(3,it)
5043         do j=2,0,-1
5044           sig=sig*thet_pred_mean+polthet(j,it)
5045         enddo
5046 C Derivative of the "interior part" of the "standard deviation of the"
5047 C gamma-dependent Gaussian lobe in t_c.
5048         sigtc=3*polthet(3,it)
5049         do j=2,1,-1
5050           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5051         enddo
5052         sigtc=sig*sigtc
5053 C Set the parameters of both Gaussian lobes of the distribution.
5054 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5055         fac=sig*sig+sigc0(it)
5056         sigcsq=fac+fac
5057         sigc=1.0D0/sigcsq
5058 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5059         sigsqtc=-4.0D0*sigcsq*sigtc
5060 c       print *,i,sig,sigtc,sigsqtc
5061 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
5062         sigtc=-sigtc/(fac*fac)
5063 C Following variable is sigma(t_c)**(-2)
5064         sigcsq=sigcsq*sigcsq
5065         sig0i=sig0(it)
5066         sig0inv=1.0D0/sig0i**2
5067         delthec=thetai-thet_pred_mean
5068         delthe0=thetai-theta0i
5069         term1=-0.5D0*sigcsq*delthec*delthec
5070         term2=-0.5D0*sig0inv*delthe0*delthe0
5071 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5072 C NaNs in taking the logarithm. We extract the largest exponent which is added
5073 C to the energy (this being the log of the distribution) at the end of energy
5074 C term evaluation for this virtual-bond angle.
5075         if (term1.gt.term2) then
5076           termm=term1
5077           term2=dexp(term2-termm)
5078           term1=1.0d0
5079         else
5080           termm=term2
5081           term1=dexp(term1-termm)
5082           term2=1.0d0
5083         endif
5084 C The ratio between the gamma-independent and gamma-dependent lobes of
5085 C the distribution is a Gaussian function of thet_pred_mean too.
5086         diffak=gthet(2,it)-thet_pred_mean
5087         ratak=diffak/gthet(3,it)**2
5088         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5089 C Let's differentiate it in thet_pred_mean NOW.
5090         aktc=ak*ratak
5091 C Now put together the distribution terms to make complete distribution.
5092         termexp=term1+ak*term2
5093         termpre=sigc+ak*sig0i
5094 C Contribution of the bending energy from this theta is just the -log of
5095 C the sum of the contributions from the two lobes and the pre-exponential
5096 C factor. Simple enough, isn't it?
5097         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5098 C NOW the derivatives!!!
5099 C 6/6/97 Take into account the deformation.
5100         E_theta=(delthec*sigcsq*term1
5101      &       +ak*delthe0*sig0inv*term2)/termexp
5102         E_tc=((sigtc+aktc*sig0i)/termpre
5103      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5104      &       aktc*term2)/termexp)
5105       return
5106       end
5107 c-----------------------------------------------------------------------------
5108       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5109       implicit real*8 (a-h,o-z)
5110       include 'DIMENSIONS'
5111       include 'COMMON.LOCAL'
5112       include 'COMMON.IOUNITS'
5113       common /calcthet/ term1,term2,termm,diffak,ratak,
5114      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5115      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5116       delthec=thetai-thet_pred_mean
5117       delthe0=thetai-theta0i
5118 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5119       t3 = thetai-thet_pred_mean
5120       t6 = t3**2
5121       t9 = term1
5122       t12 = t3*sigcsq
5123       t14 = t12+t6*sigsqtc
5124       t16 = 1.0d0
5125       t21 = thetai-theta0i
5126       t23 = t21**2
5127       t26 = term2
5128       t27 = t21*t26
5129       t32 = termexp
5130       t40 = t32**2
5131       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5132      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5133      & *(-t12*t9-ak*sig0inv*t27)
5134       return
5135       end
5136 #else
5137 C--------------------------------------------------------------------------
5138       subroutine ebend(etheta)
5139 C
5140 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5141 C angles gamma and its derivatives in consecutive thetas and gammas.
5142 C ab initio-derived potentials from
5143 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5144 C
5145       implicit real*8 (a-h,o-z)
5146       include 'DIMENSIONS'
5147       include 'DIMENSIONS.ZSCOPT'
5148       include 'COMMON.LOCAL'
5149       include 'COMMON.GEO'
5150       include 'COMMON.INTERACT'
5151       include 'COMMON.DERIV'
5152       include 'COMMON.VAR'
5153       include 'COMMON.CHAIN'
5154       include 'COMMON.IOUNITS'
5155       include 'COMMON.NAMES'
5156       include 'COMMON.FFIELD'
5157       include 'COMMON.CONTROL'
5158       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5159      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5160      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5161      & sinph1ph2(maxdouble,maxdouble)
5162       logical lprn /.false./, lprn1 /.false./
5163       etheta=0.0D0
5164 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5165       do i=ithet_start,ithet_end
5166         dethetai=0.0d0
5167         dephii=0.0d0
5168         dephii1=0.0d0
5169         theti2=0.5d0*theta(i)
5170         ityp2=ithetyp(itype(i-1))
5171         do k=1,nntheterm
5172           coskt(k)=dcos(k*theti2)
5173           sinkt(k)=dsin(k*theti2)
5174         enddo
5175         if (i.gt.3) then
5176 #ifdef OSF
5177           phii=phi(i)
5178           if (phii.ne.phii) phii=150.0
5179 #else
5180           phii=phi(i)
5181 #endif
5182           ityp1=ithetyp(itype(i-2))
5183           do k=1,nsingle
5184             cosph1(k)=dcos(k*phii)
5185             sinph1(k)=dsin(k*phii)
5186           enddo
5187         else
5188           phii=0.0d0
5189           ityp1=nthetyp+1
5190           do k=1,nsingle
5191             cosph1(k)=0.0d0
5192             sinph1(k)=0.0d0
5193           enddo
5194         endif
5195         if (i.lt.nres) then
5196 #ifdef OSF
5197           phii1=phi(i+1)
5198           if (phii1.ne.phii1) phii1=150.0
5199           phii1=pinorm(phii1)
5200 #else
5201           phii1=phi(i+1)
5202 #endif
5203           ityp3=ithetyp(itype(i))
5204           do k=1,nsingle
5205             cosph2(k)=dcos(k*phii1)
5206             sinph2(k)=dsin(k*phii1)
5207           enddo
5208         else
5209           phii1=0.0d0
5210           ityp3=nthetyp+1
5211           do k=1,nsingle
5212             cosph2(k)=0.0d0
5213             sinph2(k)=0.0d0
5214           enddo
5215         endif
5216 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5217 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5218 c        call flush(iout)
5219         ethetai=aa0thet(ityp1,ityp2,ityp3)
5220         do k=1,ndouble
5221           do l=1,k-1
5222             ccl=cosph1(l)*cosph2(k-l)
5223             ssl=sinph1(l)*sinph2(k-l)
5224             scl=sinph1(l)*cosph2(k-l)
5225             csl=cosph1(l)*sinph2(k-l)
5226             cosph1ph2(l,k)=ccl-ssl
5227             cosph1ph2(k,l)=ccl+ssl
5228             sinph1ph2(l,k)=scl+csl
5229             sinph1ph2(k,l)=scl-csl
5230           enddo
5231         enddo
5232         if (lprn) then
5233         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5234      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5235         write (iout,*) "coskt and sinkt"
5236         do k=1,nntheterm
5237           write (iout,*) k,coskt(k),sinkt(k)
5238         enddo
5239         endif
5240         do k=1,ntheterm
5241           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
5242           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
5243      &      *coskt(k)
5244           if (lprn)
5245      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
5246      &     " ethetai",ethetai
5247         enddo
5248         if (lprn) then
5249         write (iout,*) "cosph and sinph"
5250         do k=1,nsingle
5251           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5252         enddo
5253         write (iout,*) "cosph1ph2 and sinph2ph2"
5254         do k=2,ndouble
5255           do l=1,k-1
5256             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5257      &         sinph1ph2(l,k),sinph1ph2(k,l)
5258           enddo
5259         enddo
5260         write(iout,*) "ethetai",ethetai
5261         endif
5262         do m=1,ntheterm2
5263           do k=1,nsingle
5264             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
5265      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
5266      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
5267      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
5268             ethetai=ethetai+sinkt(m)*aux
5269             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5270             dephii=dephii+k*sinkt(m)*(
5271      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
5272      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
5273             dephii1=dephii1+k*sinkt(m)*(
5274      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
5275      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
5276             if (lprn)
5277      &      write (iout,*) "m",m," k",k," bbthet",
5278      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
5279      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
5280      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
5281      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5282           enddo
5283         enddo
5284         if (lprn)
5285      &  write(iout,*) "ethetai",ethetai
5286         do m=1,ntheterm3
5287           do k=2,ndouble
5288             do l=1,k-1
5289               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5290      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
5291      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5292      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
5293               ethetai=ethetai+sinkt(m)*aux
5294               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5295               dephii=dephii+l*sinkt(m)*(
5296      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
5297      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5298      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5299      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5300               dephii1=dephii1+(k-l)*sinkt(m)*(
5301      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5302      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5303      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5304      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5305               if (lprn) then
5306               write (iout,*) "m",m," k",k," l",l," ffthet",
5307      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5308      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5309      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5310      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5311               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5312      &            cosph1ph2(k,l)*sinkt(m),
5313      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5314               endif
5315             enddo
5316           enddo
5317         enddo
5318 10      continue
5319         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5320      &   i,theta(i)*rad2deg,phii*rad2deg,
5321      &   phii1*rad2deg,ethetai
5322         etheta=etheta+ethetai
5323         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5324         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5325         gloc(nphi+i-2,icg)=wang*dethetai
5326       enddo
5327       return
5328       end
5329 #endif
5330 #ifdef CRYST_SC
5331 c-----------------------------------------------------------------------------
5332       subroutine esc(escloc)
5333 C Calculate the local energy of a side chain and its derivatives in the
5334 C corresponding virtual-bond valence angles THETA and the spherical angles
5335 C ALPHA and OMEGA.
5336       implicit real*8 (a-h,o-z)
5337       include 'DIMENSIONS'
5338       include 'DIMENSIONS.ZSCOPT'
5339       include 'COMMON.GEO'
5340       include 'COMMON.LOCAL'
5341       include 'COMMON.VAR'
5342       include 'COMMON.INTERACT'
5343       include 'COMMON.DERIV'
5344       include 'COMMON.CHAIN'
5345       include 'COMMON.IOUNITS'
5346       include 'COMMON.NAMES'
5347       include 'COMMON.FFIELD'
5348       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5349      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5350       common /sccalc/ time11,time12,time112,theti,it,nlobit
5351       delta=0.02d0*pi
5352       escloc=0.0D0
5353 c     write (iout,'(a)') 'ESC'
5354       do i=loc_start,loc_end
5355         it=itype(i)
5356         if (it.eq.10) goto 1
5357         nlobit=nlob(it)
5358 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5359 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5360         theti=theta(i+1)-pipol
5361         x(1)=dtan(theti)
5362         x(2)=alph(i)
5363         x(3)=omeg(i)
5364 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5365
5366         if (x(2).gt.pi-delta) then
5367           xtemp(1)=x(1)
5368           xtemp(2)=pi-delta
5369           xtemp(3)=x(3)
5370           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5371           xtemp(2)=pi
5372           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5373           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5374      &        escloci,dersc(2))
5375           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5376      &        ddersc0(1),dersc(1))
5377           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5378      &        ddersc0(3),dersc(3))
5379           xtemp(2)=pi-delta
5380           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5381           xtemp(2)=pi
5382           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5383           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5384      &            dersc0(2),esclocbi,dersc02)
5385           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5386      &            dersc12,dersc01)
5387           call splinthet(x(2),0.5d0*delta,ss,ssd)
5388           dersc0(1)=dersc01
5389           dersc0(2)=dersc02
5390           dersc0(3)=0.0d0
5391           do k=1,3
5392             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5393           enddo
5394           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5395 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5396 c    &             esclocbi,ss,ssd
5397           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5398 c         escloci=esclocbi
5399 c         write (iout,*) escloci
5400         else if (x(2).lt.delta) then
5401           xtemp(1)=x(1)
5402           xtemp(2)=delta
5403           xtemp(3)=x(3)
5404           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5405           xtemp(2)=0.0d0
5406           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5407           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5408      &        escloci,dersc(2))
5409           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5410      &        ddersc0(1),dersc(1))
5411           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5412      &        ddersc0(3),dersc(3))
5413           xtemp(2)=delta
5414           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5415           xtemp(2)=0.0d0
5416           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5417           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5418      &            dersc0(2),esclocbi,dersc02)
5419           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5420      &            dersc12,dersc01)
5421           dersc0(1)=dersc01
5422           dersc0(2)=dersc02
5423           dersc0(3)=0.0d0
5424           call splinthet(x(2),0.5d0*delta,ss,ssd)
5425           do k=1,3
5426             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5427           enddo
5428           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5429 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5430 c    &             esclocbi,ss,ssd
5431           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5432 c         write (iout,*) escloci
5433         else
5434           call enesc(x,escloci,dersc,ddummy,.false.)
5435         endif
5436
5437         escloc=escloc+escloci
5438 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5439
5440         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5441      &   wscloc*dersc(1)
5442         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5443         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5444     1   continue
5445       enddo
5446       return
5447       end
5448 C---------------------------------------------------------------------------
5449       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5450       implicit real*8 (a-h,o-z)
5451       include 'DIMENSIONS'
5452       include 'COMMON.GEO'
5453       include 'COMMON.LOCAL'
5454       include 'COMMON.IOUNITS'
5455       common /sccalc/ time11,time12,time112,theti,it,nlobit
5456       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5457       double precision contr(maxlob,-1:1)
5458       logical mixed
5459 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5460         escloc_i=0.0D0
5461         do j=1,3
5462           dersc(j)=0.0D0
5463           if (mixed) ddersc(j)=0.0d0
5464         enddo
5465         x3=x(3)
5466
5467 C Because of periodicity of the dependence of the SC energy in omega we have
5468 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5469 C To avoid underflows, first compute & store the exponents.
5470
5471         do iii=-1,1
5472
5473           x(3)=x3+iii*dwapi
5474
5475           do j=1,nlobit
5476             do k=1,3
5477               z(k)=x(k)-censc(k,j,it)
5478             enddo
5479             do k=1,3
5480               Axk=0.0D0
5481               do l=1,3
5482                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5483               enddo
5484               Ax(k,j,iii)=Axk
5485             enddo
5486             expfac=0.0D0
5487             do k=1,3
5488               expfac=expfac+Ax(k,j,iii)*z(k)
5489             enddo
5490             contr(j,iii)=expfac
5491           enddo ! j
5492
5493         enddo ! iii
5494
5495         x(3)=x3
5496 C As in the case of ebend, we want to avoid underflows in exponentiation and
5497 C subsequent NaNs and INFs in energy calculation.
5498 C Find the largest exponent
5499         emin=contr(1,-1)
5500         do iii=-1,1
5501           do j=1,nlobit
5502             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5503           enddo
5504         enddo
5505         emin=0.5D0*emin
5506 cd      print *,'it=',it,' emin=',emin
5507
5508 C Compute the contribution to SC energy and derivatives
5509         do iii=-1,1
5510
5511           do j=1,nlobit
5512             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5513 cd          print *,'j=',j,' expfac=',expfac
5514             escloc_i=escloc_i+expfac
5515             do k=1,3
5516               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5517             enddo
5518             if (mixed) then
5519               do k=1,3,2
5520                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5521      &            +gaussc(k,2,j,it))*expfac
5522               enddo
5523             endif
5524           enddo
5525
5526         enddo ! iii
5527
5528         dersc(1)=dersc(1)/cos(theti)**2
5529         ddersc(1)=ddersc(1)/cos(theti)**2
5530         ddersc(3)=ddersc(3)
5531
5532         escloci=-(dlog(escloc_i)-emin)
5533         do j=1,3
5534           dersc(j)=dersc(j)/escloc_i
5535         enddo
5536         if (mixed) then
5537           do j=1,3,2
5538             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5539           enddo
5540         endif
5541       return
5542       end
5543 C------------------------------------------------------------------------------
5544       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5545       implicit real*8 (a-h,o-z)
5546       include 'DIMENSIONS'
5547       include 'COMMON.GEO'
5548       include 'COMMON.LOCAL'
5549       include 'COMMON.IOUNITS'
5550       common /sccalc/ time11,time12,time112,theti,it,nlobit
5551       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5552       double precision contr(maxlob)
5553       logical mixed
5554
5555       escloc_i=0.0D0
5556
5557       do j=1,3
5558         dersc(j)=0.0D0
5559       enddo
5560
5561       do j=1,nlobit
5562         do k=1,2
5563           z(k)=x(k)-censc(k,j,it)
5564         enddo
5565         z(3)=dwapi
5566         do k=1,3
5567           Axk=0.0D0
5568           do l=1,3
5569             Axk=Axk+gaussc(l,k,j,it)*z(l)
5570           enddo
5571           Ax(k,j)=Axk
5572         enddo
5573         expfac=0.0D0
5574         do k=1,3
5575           expfac=expfac+Ax(k,j)*z(k)
5576         enddo
5577         contr(j)=expfac
5578       enddo ! j
5579
5580 C As in the case of ebend, we want to avoid underflows in exponentiation and
5581 C subsequent NaNs and INFs in energy calculation.
5582 C Find the largest exponent
5583       emin=contr(1)
5584       do j=1,nlobit
5585         if (emin.gt.contr(j)) emin=contr(j)
5586       enddo
5587       emin=0.5D0*emin
5588
5589 C Compute the contribution to SC energy and derivatives
5590
5591       dersc12=0.0d0
5592       do j=1,nlobit
5593         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5594         escloc_i=escloc_i+expfac
5595         do k=1,2
5596           dersc(k)=dersc(k)+Ax(k,j)*expfac
5597         enddo
5598         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5599      &            +gaussc(1,2,j,it))*expfac
5600         dersc(3)=0.0d0
5601       enddo
5602
5603       dersc(1)=dersc(1)/cos(theti)**2
5604       dersc12=dersc12/cos(theti)**2
5605       escloci=-(dlog(escloc_i)-emin)
5606       do j=1,2
5607         dersc(j)=dersc(j)/escloc_i
5608       enddo
5609       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5610       return
5611       end
5612 #else
5613 c----------------------------------------------------------------------------------
5614       subroutine esc(escloc)
5615 C Calculate the local energy of a side chain and its derivatives in the
5616 C corresponding virtual-bond valence angles THETA and the spherical angles
5617 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5618 C added by Urszula Kozlowska. 07/11/2007
5619 C
5620       implicit real*8 (a-h,o-z)
5621       include 'DIMENSIONS'
5622       include 'DIMENSIONS.ZSCOPT'
5623       include 'COMMON.GEO'
5624       include 'COMMON.LOCAL'
5625       include 'COMMON.VAR'
5626       include 'COMMON.SCROT'
5627       include 'COMMON.INTERACT'
5628       include 'COMMON.DERIV'
5629       include 'COMMON.CHAIN'
5630       include 'COMMON.IOUNITS'
5631       include 'COMMON.NAMES'
5632       include 'COMMON.FFIELD'
5633       include 'COMMON.CONTROL'
5634       include 'COMMON.VECTORS'
5635       double precision x_prime(3),y_prime(3),z_prime(3)
5636      &    , sumene,dsc_i,dp2_i,x(65),
5637      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5638      &    de_dxx,de_dyy,de_dzz,de_dt
5639       double precision s1_t,s1_6_t,s2_t,s2_6_t
5640       double precision
5641      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5642      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5643      & dt_dCi(3),dt_dCi1(3)
5644       common /sccalc/ time11,time12,time112,theti,it,nlobit
5645       delta=0.02d0*pi
5646       escloc=0.0D0
5647       do i=loc_start,loc_end
5648         costtab(i+1) =dcos(theta(i+1))
5649         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5650         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5651         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5652         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5653         cosfac=dsqrt(cosfac2)
5654         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5655         sinfac=dsqrt(sinfac2)
5656         it=itype(i)
5657         if (it.eq.10) goto 1
5658 c
5659 C  Compute the axes of tghe local cartesian coordinates system; store in
5660 c   x_prime, y_prime and z_prime
5661 c
5662         do j=1,3
5663           x_prime(j) = 0.00
5664           y_prime(j) = 0.00
5665           z_prime(j) = 0.00
5666         enddo
5667 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5668 C     &   dc_norm(3,i+nres)
5669         do j = 1,3
5670           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5671           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5672         enddo
5673         do j = 1,3
5674           z_prime(j) = -uz(j,i-1)
5675         enddo
5676 c       write (2,*) "i",i
5677 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5678 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5679 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5680 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5681 c      & " xy",scalar(x_prime(1),y_prime(1)),
5682 c      & " xz",scalar(x_prime(1),z_prime(1)),
5683 c      & " yy",scalar(y_prime(1),y_prime(1)),
5684 c      & " yz",scalar(y_prime(1),z_prime(1)),
5685 c      & " zz",scalar(z_prime(1),z_prime(1))
5686 c
5687 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5688 C to local coordinate system. Store in xx, yy, zz.
5689 c
5690         xx=0.0d0
5691         yy=0.0d0
5692         zz=0.0d0
5693         do j = 1,3
5694           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5695           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5696           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5697         enddo
5698
5699         xxtab(i)=xx
5700         yytab(i)=yy
5701         zztab(i)=zz
5702 C
5703 C Compute the energy of the ith side cbain
5704 C
5705 c        write (2,*) "xx",xx," yy",yy," zz",zz
5706         it=itype(i)
5707         do j = 1,65
5708           x(j) = sc_parmin(j,it)
5709         enddo
5710 #ifdef CHECK_COORD
5711 Cc diagnostics - remove later
5712         xx1 = dcos(alph(2))
5713         yy1 = dsin(alph(2))*dcos(omeg(2))
5714         zz1 = -dsin(alph(2))*dsin(omeg(2))
5715         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5716      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5717      &    xx1,yy1,zz1
5718 C,"  --- ", xx_w,yy_w,zz_w
5719 c end diagnostics
5720 #endif
5721         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5722      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5723      &   + x(10)*yy*zz
5724         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5725      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5726      & + x(20)*yy*zz
5727         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5728      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5729      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5730      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5731      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5732      &  +x(40)*xx*yy*zz
5733         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5734      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5735      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5736      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5737      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5738      &  +x(60)*xx*yy*zz
5739         dsc_i   = 0.743d0+x(61)
5740         dp2_i   = 1.9d0+x(62)
5741         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5742      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5743         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5744      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5745         s1=(1+x(63))/(0.1d0 + dscp1)
5746         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5747         s2=(1+x(65))/(0.1d0 + dscp2)
5748         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5749         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5750      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5751 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5752 c     &   sumene4,
5753 c     &   dscp1,dscp2,sumene
5754 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5755         escloc = escloc + sumene
5756 c        write (2,*) "escloc",escloc
5757         if (.not. calc_grad) goto 1
5758 #ifdef DEBUG
5759 C
5760 C This section to check the numerical derivatives of the energy of ith side
5761 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5762 C #define DEBUG in the code to turn it on.
5763 C
5764         write (2,*) "sumene               =",sumene
5765         aincr=1.0d-7
5766         xxsave=xx
5767         xx=xx+aincr
5768         write (2,*) xx,yy,zz
5769         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5770         de_dxx_num=(sumenep-sumene)/aincr
5771         xx=xxsave
5772         write (2,*) "xx+ sumene from enesc=",sumenep
5773         yysave=yy
5774         yy=yy+aincr
5775         write (2,*) xx,yy,zz
5776         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5777         de_dyy_num=(sumenep-sumene)/aincr
5778         yy=yysave
5779         write (2,*) "yy+ sumene from enesc=",sumenep
5780         zzsave=zz
5781         zz=zz+aincr
5782         write (2,*) xx,yy,zz
5783         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5784         de_dzz_num=(sumenep-sumene)/aincr
5785         zz=zzsave
5786         write (2,*) "zz+ sumene from enesc=",sumenep
5787         costsave=cost2tab(i+1)
5788         sintsave=sint2tab(i+1)
5789         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5790         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5791         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5792         de_dt_num=(sumenep-sumene)/aincr
5793         write (2,*) " t+ sumene from enesc=",sumenep
5794         cost2tab(i+1)=costsave
5795         sint2tab(i+1)=sintsave
5796 C End of diagnostics section.
5797 #endif
5798 C
5799 C Compute the gradient of esc
5800 C
5801         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5802         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5803         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5804         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5805         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5806         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5807         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5808         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5809         pom1=(sumene3*sint2tab(i+1)+sumene1)
5810      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5811         pom2=(sumene4*cost2tab(i+1)+sumene2)
5812      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5813         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5814         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5815      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5816      &  +x(40)*yy*zz
5817         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5818         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5819      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5820      &  +x(60)*yy*zz
5821         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5822      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5823      &        +(pom1+pom2)*pom_dx
5824 #ifdef DEBUG
5825         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5826 #endif
5827 C
5828         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5829         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5830      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5831      &  +x(40)*xx*zz
5832         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5833         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5834      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5835      &  +x(59)*zz**2 +x(60)*xx*zz
5836         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5837      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5838      &        +(pom1-pom2)*pom_dy
5839 #ifdef DEBUG
5840         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5841 #endif
5842 C
5843         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5844      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5845      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5846      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5847      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5848      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5849      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5850      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5851 #ifdef DEBUG
5852         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5853 #endif
5854 C
5855         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5856      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5857      &  +pom1*pom_dt1+pom2*pom_dt2
5858 #ifdef DEBUG
5859         write(2,*), "de_dt = ", de_dt,de_dt_num
5860 #endif
5861 c
5862 C
5863        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5864        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5865        cosfac2xx=cosfac2*xx
5866        sinfac2yy=sinfac2*yy
5867        do k = 1,3
5868          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5869      &      vbld_inv(i+1)
5870          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5871      &      vbld_inv(i)
5872          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5873          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5874 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5875 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5876 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5877 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5878          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5879          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5880          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5881          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5882          dZZ_Ci1(k)=0.0d0
5883          dZZ_Ci(k)=0.0d0
5884          do j=1,3
5885            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5886            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5887          enddo
5888
5889          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5890          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5891          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5892 c
5893          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5894          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5895        enddo
5896
5897        do k=1,3
5898          dXX_Ctab(k,i)=dXX_Ci(k)
5899          dXX_C1tab(k,i)=dXX_Ci1(k)
5900          dYY_Ctab(k,i)=dYY_Ci(k)
5901          dYY_C1tab(k,i)=dYY_Ci1(k)
5902          dZZ_Ctab(k,i)=dZZ_Ci(k)
5903          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5904          dXX_XYZtab(k,i)=dXX_XYZ(k)
5905          dYY_XYZtab(k,i)=dYY_XYZ(k)
5906          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5907        enddo
5908
5909        do k = 1,3
5910 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5911 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5912 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5913 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5914 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5915 c     &    dt_dci(k)
5916 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5917 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5918          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5919      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5920          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5921      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5922          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5923      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5924        enddo
5925 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5926 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5927
5928 C to check gradient call subroutine check_grad
5929
5930     1 continue
5931       enddo
5932       return
5933       end
5934 #endif
5935 c------------------------------------------------------------------------------
5936       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5937 C
5938 C This procedure calculates two-body contact function g(rij) and its derivative:
5939 C
5940 C           eps0ij                                     !       x < -1
5941 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5942 C            0                                         !       x > 1
5943 C
5944 C where x=(rij-r0ij)/delta
5945 C
5946 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5947 C
5948       implicit none
5949       double precision rij,r0ij,eps0ij,fcont,fprimcont
5950       double precision x,x2,x4,delta
5951 c     delta=0.02D0*r0ij
5952 c      delta=0.2D0*r0ij
5953       x=(rij-r0ij)/delta
5954       if (x.lt.-1.0D0) then
5955         fcont=eps0ij
5956         fprimcont=0.0D0
5957       else if (x.le.1.0D0) then
5958         x2=x*x
5959         x4=x2*x2
5960         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5961         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5962       else
5963         fcont=0.0D0
5964         fprimcont=0.0D0
5965       endif
5966       return
5967       end
5968 c------------------------------------------------------------------------------
5969       subroutine splinthet(theti,delta,ss,ssder)
5970       implicit real*8 (a-h,o-z)
5971       include 'DIMENSIONS'
5972       include 'DIMENSIONS.ZSCOPT'
5973       include 'COMMON.VAR'
5974       include 'COMMON.GEO'
5975       thetup=pi-delta
5976       thetlow=delta
5977       if (theti.gt.pipol) then
5978         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5979       else
5980         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5981         ssder=-ssder
5982       endif
5983       return
5984       end
5985 c------------------------------------------------------------------------------
5986       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5987       implicit none
5988       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5989       double precision ksi,ksi2,ksi3,a1,a2,a3
5990       a1=fprim0*delta/(f1-f0)
5991       a2=3.0d0-2.0d0*a1
5992       a3=a1-2.0d0
5993       ksi=(x-x0)/delta
5994       ksi2=ksi*ksi
5995       ksi3=ksi2*ksi
5996       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5997       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5998       return
5999       end
6000 c------------------------------------------------------------------------------
6001       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6002       implicit none
6003       double precision x,x0,delta,f0x,f1x,fprim0x,fx
6004       double precision ksi,ksi2,ksi3,a1,a2,a3
6005       ksi=(x-x0)/delta
6006       ksi2=ksi*ksi
6007       ksi3=ksi2*ksi
6008       a1=fprim0x*delta
6009       a2=3*(f1x-f0x)-2*fprim0x*delta
6010       a3=fprim0x*delta-2*(f1x-f0x)
6011       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6012       return
6013       end
6014 C-----------------------------------------------------------------------------
6015 #ifdef CRYST_TOR
6016 C-----------------------------------------------------------------------------
6017       subroutine etor(etors,edihcnstr,fact)
6018       implicit real*8 (a-h,o-z)
6019       include 'DIMENSIONS'
6020       include 'DIMENSIONS.ZSCOPT'
6021       include 'COMMON.VAR'
6022       include 'COMMON.GEO'
6023       include 'COMMON.LOCAL'
6024       include 'COMMON.TORSION'
6025       include 'COMMON.INTERACT'
6026       include 'COMMON.DERIV'
6027       include 'COMMON.CHAIN'
6028       include 'COMMON.NAMES'
6029       include 'COMMON.IOUNITS'
6030       include 'COMMON.FFIELD'
6031       include 'COMMON.TORCNSTR'
6032       logical lprn
6033 C Set lprn=.true. for debugging
6034       lprn=.false.
6035 c      lprn=.true.
6036       etors=0.0D0
6037       do i=iphi_start,iphi_end
6038         itori=itortyp(itype(i-2))
6039         itori1=itortyp(itype(i-1))
6040         phii=phi(i)
6041         gloci=0.0D0
6042 C Proline-Proline pair is a special case...
6043         if (itori.eq.3 .and. itori1.eq.3) then
6044           if (phii.gt.-dwapi3) then
6045             cosphi=dcos(3*phii)
6046             fac=1.0D0/(1.0D0-cosphi)
6047             etorsi=v1(1,3,3)*fac
6048             etorsi=etorsi+etorsi
6049             etors=etors+etorsi-v1(1,3,3)
6050             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6051           endif
6052           do j=1,3
6053             v1ij=v1(j+1,itori,itori1)
6054             v2ij=v2(j+1,itori,itori1)
6055             cosphi=dcos(j*phii)
6056             sinphi=dsin(j*phii)
6057             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6058             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6059           enddo
6060         else
6061           do j=1,nterm_old
6062             v1ij=v1(j,itori,itori1)
6063             v2ij=v2(j,itori,itori1)
6064             cosphi=dcos(j*phii)
6065             sinphi=dsin(j*phii)
6066             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6067             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6068           enddo
6069         endif
6070         if (lprn)
6071      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6072      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6073      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6074         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6075 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6076       enddo
6077 ! 6/20/98 - dihedral angle constraints
6078       edihcnstr=0.0d0
6079       do i=1,ndih_constr
6080         itori=idih_constr(i)
6081         phii=phi(itori)
6082         difi=phii-phi0(i)
6083         if (difi.gt.drange(i)) then
6084           difi=difi-drange(i)
6085           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6086           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6087         else if (difi.lt.-drange(i)) then
6088           difi=difi+drange(i)
6089           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6090           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6091         endif
6092 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6093 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6094       enddo
6095 !      write (iout,*) 'edihcnstr',edihcnstr
6096       return
6097       end
6098 c------------------------------------------------------------------------------
6099 #else
6100       subroutine etor(etors,edihcnstr,fact)
6101       implicit real*8 (a-h,o-z)
6102       include 'DIMENSIONS'
6103       include 'DIMENSIONS.ZSCOPT'
6104       include 'COMMON.VAR'
6105       include 'COMMON.GEO'
6106       include 'COMMON.LOCAL'
6107       include 'COMMON.TORSION'
6108       include 'COMMON.INTERACT'
6109       include 'COMMON.DERIV'
6110       include 'COMMON.CHAIN'
6111       include 'COMMON.NAMES'
6112       include 'COMMON.IOUNITS'
6113       include 'COMMON.FFIELD'
6114       include 'COMMON.TORCNSTR'
6115       logical lprn
6116 C Set lprn=.true. for debugging
6117       lprn=.false.
6118 c      lprn=.true.
6119       etors=0.0D0
6120       do i=iphi_start,iphi_end
6121         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6122         itori=itortyp(itype(i-2))
6123         itori1=itortyp(itype(i-1))
6124         phii=phi(i)
6125         gloci=0.0D0
6126 C Regular cosine and sine terms
6127         do j=1,nterm(itori,itori1)
6128           v1ij=v1(j,itori,itori1)
6129           v2ij=v2(j,itori,itori1)
6130           cosphi=dcos(j*phii)
6131           sinphi=dsin(j*phii)
6132           etors=etors+v1ij*cosphi+v2ij*sinphi
6133           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6134         enddo
6135 C Lorentz terms
6136 C                         v1
6137 C  E = SUM ----------------------------------- - v1
6138 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6139 C
6140         cosphi=dcos(0.5d0*phii)
6141         sinphi=dsin(0.5d0*phii)
6142         do j=1,nlor(itori,itori1)
6143           vl1ij=vlor1(j,itori,itori1)
6144           vl2ij=vlor2(j,itori,itori1)
6145           vl3ij=vlor3(j,itori,itori1)
6146           pom=vl2ij*cosphi+vl3ij*sinphi
6147           pom1=1.0d0/(pom*pom+1.0d0)
6148           etors=etors+vl1ij*pom1
6149           pom=-pom*pom1*pom1
6150           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6151         enddo
6152 C Subtract the constant term
6153         etors=etors-v0(itori,itori1)
6154         if (lprn)
6155      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6156      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6157      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6158         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6159 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6160  1215   continue
6161       enddo
6162 ! 6/20/98 - dihedral angle constraints
6163       edihcnstr=0.0d0
6164       do i=1,ndih_constr
6165         itori=idih_constr(i)
6166         phii=phi(itori)
6167         difi=pinorm(phii-phi0(i))
6168         edihi=0.0d0
6169         if (difi.gt.drange(i)) then
6170           difi=difi-drange(i)
6171           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6172           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6173           edihi=0.25d0*ftors*difi**4
6174         else if (difi.lt.-drange(i)) then
6175           difi=difi+drange(i)
6176           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6177           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6178           edihi=0.25d0*ftors*difi**4
6179         else
6180           difi=0.0d0
6181         endif
6182 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
6183 c     &    drange(i),edihi
6184 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6185 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6186       enddo
6187 !      write (iout,*) 'edihcnstr',edihcnstr
6188       return
6189       end
6190 c----------------------------------------------------------------------------
6191       subroutine etor_d(etors_d,fact2)
6192 C 6/23/01 Compute double torsional energy
6193       implicit real*8 (a-h,o-z)
6194       include 'DIMENSIONS'
6195       include 'DIMENSIONS.ZSCOPT'
6196       include 'COMMON.VAR'
6197       include 'COMMON.GEO'
6198       include 'COMMON.LOCAL'
6199       include 'COMMON.TORSION'
6200       include 'COMMON.INTERACT'
6201       include 'COMMON.DERIV'
6202       include 'COMMON.CHAIN'
6203       include 'COMMON.NAMES'
6204       include 'COMMON.IOUNITS'
6205       include 'COMMON.FFIELD'
6206       include 'COMMON.TORCNSTR'
6207       logical lprn
6208 C Set lprn=.true. for debugging
6209       lprn=.false.
6210 c     lprn=.true.
6211       etors_d=0.0D0
6212       do i=iphi_start,iphi_end-1
6213         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6214      &     goto 1215
6215         itori=itortyp(itype(i-2))
6216         itori1=itortyp(itype(i-1))
6217         itori2=itortyp(itype(i))
6218         phii=phi(i)
6219         phii1=phi(i+1)
6220         gloci1=0.0D0
6221         gloci2=0.0D0
6222 C Regular cosine and sine terms
6223         do j=1,ntermd_1(itori,itori1,itori2)
6224           v1cij=v1c(1,j,itori,itori1,itori2)
6225           v1sij=v1s(1,j,itori,itori1,itori2)
6226           v2cij=v1c(2,j,itori,itori1,itori2)
6227           v2sij=v1s(2,j,itori,itori1,itori2)
6228           cosphi1=dcos(j*phii)
6229           sinphi1=dsin(j*phii)
6230           cosphi2=dcos(j*phii1)
6231           sinphi2=dsin(j*phii1)
6232           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6233      &     v2cij*cosphi2+v2sij*sinphi2
6234           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6235           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6236         enddo
6237         do k=2,ntermd_2(itori,itori1,itori2)
6238           do l=1,k-1
6239             v1cdij = v2c(k,l,itori,itori1,itori2)
6240             v2cdij = v2c(l,k,itori,itori1,itori2)
6241             v1sdij = v2s(k,l,itori,itori1,itori2)
6242             v2sdij = v2s(l,k,itori,itori1,itori2)
6243             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6244             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6245             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6246             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6247             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6248      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6249             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6250      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6251             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6252      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6253           enddo
6254         enddo
6255         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6256         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6257  1215   continue
6258       enddo
6259       return
6260       end
6261 #endif
6262 c------------------------------------------------------------------------------
6263       subroutine eback_sc_corr(esccor)
6264 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6265 c        conformational states; temporarily implemented as differences
6266 c        between UNRES torsional potentials (dependent on three types of
6267 c        residues) and the torsional potentials dependent on all 20 types
6268 c        of residues computed from AM1 energy surfaces of terminally-blocked
6269 c        amino-acid residues.
6270       implicit real*8 (a-h,o-z)
6271       include 'DIMENSIONS'
6272       include 'DIMENSIONS.ZSCOPT'
6273       include 'COMMON.VAR'
6274       include 'COMMON.GEO'
6275       include 'COMMON.LOCAL'
6276       include 'COMMON.TORSION'
6277       include 'COMMON.SCCOR'
6278       include 'COMMON.INTERACT'
6279       include 'COMMON.DERIV'
6280       include 'COMMON.CHAIN'
6281       include 'COMMON.NAMES'
6282       include 'COMMON.IOUNITS'
6283       include 'COMMON.FFIELD'
6284       include 'COMMON.CONTROL'
6285       logical lprn
6286 C Set lprn=.true. for debugging
6287       lprn=.false.
6288 c      lprn=.true.
6289 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
6290       esccor=0.0D0
6291       do i=itau_start,itau_end
6292         esccor_ii=0.0D0
6293         isccori=isccortyp(itype(i-2))
6294         isccori1=isccortyp(itype(i-1))
6295         phii=phi(i)
6296 cccc  Added 9 May 2012
6297 cc Tauangle is torsional engle depending on the value of first digit
6298 c(see comment below)
6299 cc Omicron is flat angle depending on the value of first digit
6300 c(see comment below)
6301
6302
6303         do intertyp=1,3 !intertyp
6304 cc Added 09 May 2012 (Adasko)
6305 cc  Intertyp means interaction type of backbone mainchain correlation:
6306 c   1 = SC...Ca...Ca...Ca
6307 c   2 = Ca...Ca...Ca...SC
6308 c   3 = SC...Ca...Ca...SCi
6309         gloci=0.0D0
6310         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6311      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6312      &      (itype(i-1).eq.21)))
6313      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6314      &     .or.(itype(i-2).eq.21)))
6315      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6316      &      (itype(i-1).eq.21)))) cycle
6317         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6318         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6319      & cycle
6320         do j=1,nterm_sccor(isccori,isccori1)
6321           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6322           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6323           cosphi=dcos(j*tauangle(intertyp,i))
6324           sinphi=dsin(j*tauangle(intertyp,i))
6325           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6326           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6327         enddo
6328         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6329 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6330 c     &gloc_sc(intertyp,i-3,icg)
6331         if (lprn)
6332      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6333      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6334      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6335      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6336         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6337        enddo !intertyp
6338       enddo
6339 c        do i=1,nres
6340 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6341 c        enddo
6342       return
6343       end
6344 c------------------------------------------------------------------------------
6345       subroutine multibody(ecorr)
6346 C This subroutine calculates multi-body contributions to energy following
6347 C the idea of Skolnick et al. If side chains I and J make a contact and
6348 C at the same time side chains I+1 and J+1 make a contact, an extra
6349 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6350       implicit real*8 (a-h,o-z)
6351       include 'DIMENSIONS'
6352       include 'COMMON.IOUNITS'
6353       include 'COMMON.DERIV'
6354       include 'COMMON.INTERACT'
6355       include 'COMMON.CONTACTS'
6356       double precision gx(3),gx1(3)
6357       logical lprn
6358
6359 C Set lprn=.true. for debugging
6360       lprn=.false.
6361
6362       if (lprn) then
6363         write (iout,'(a)') 'Contact function values:'
6364         do i=nnt,nct-2
6365           write (iout,'(i2,20(1x,i2,f10.5))')
6366      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6367         enddo
6368       endif
6369       ecorr=0.0D0
6370       do i=nnt,nct
6371         do j=1,3
6372           gradcorr(j,i)=0.0D0
6373           gradxorr(j,i)=0.0D0
6374         enddo
6375       enddo
6376       do i=nnt,nct-2
6377
6378         DO ISHIFT = 3,4
6379
6380         i1=i+ishift
6381         num_conti=num_cont(i)
6382         num_conti1=num_cont(i1)
6383         do jj=1,num_conti
6384           j=jcont(jj,i)
6385           do kk=1,num_conti1
6386             j1=jcont(kk,i1)
6387             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6388 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6389 cd   &                   ' ishift=',ishift
6390 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6391 C The system gains extra energy.
6392               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6393             endif   ! j1==j+-ishift
6394           enddo     ! kk
6395         enddo       ! jj
6396
6397         ENDDO ! ISHIFT
6398
6399       enddo         ! i
6400       return
6401       end
6402 c------------------------------------------------------------------------------
6403       double precision function esccorr(i,j,k,l,jj,kk)
6404       implicit real*8 (a-h,o-z)
6405       include 'DIMENSIONS'
6406       include 'COMMON.IOUNITS'
6407       include 'COMMON.DERIV'
6408       include 'COMMON.INTERACT'
6409       include 'COMMON.CONTACTS'
6410       double precision gx(3),gx1(3)
6411       logical lprn
6412       lprn=.false.
6413       eij=facont(jj,i)
6414       ekl=facont(kk,k)
6415 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6416 C Calculate the multi-body contribution to energy.
6417 C Calculate multi-body contributions to the gradient.
6418 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6419 cd   & k,l,(gacont(m,kk,k),m=1,3)
6420       do m=1,3
6421         gx(m) =ekl*gacont(m,jj,i)
6422         gx1(m)=eij*gacont(m,kk,k)
6423         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6424         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6425         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6426         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6427       enddo
6428       do m=i,j-1
6429         do ll=1,3
6430           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6431         enddo
6432       enddo
6433       do m=k,l-1
6434         do ll=1,3
6435           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6436         enddo
6437       enddo
6438       esccorr=-eij*ekl
6439       return
6440       end
6441 c------------------------------------------------------------------------------
6442 #ifdef MPL
6443       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
6444       implicit real*8 (a-h,o-z)
6445       include 'DIMENSIONS'
6446       integer dimen1,dimen2,atom,indx
6447       double precision buffer(dimen1,dimen2)
6448       double precision zapas
6449       common /contacts_hb/ zapas(3,20,maxres,7),
6450      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6451      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6452       num_kont=num_cont_hb(atom)
6453       do i=1,num_kont
6454         do k=1,7
6455           do j=1,3
6456             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
6457           enddo ! j
6458         enddo ! k
6459         buffer(i,indx+22)=facont_hb(i,atom)
6460         buffer(i,indx+23)=ees0p(i,atom)
6461         buffer(i,indx+24)=ees0m(i,atom)
6462         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
6463       enddo ! i
6464       buffer(1,indx+26)=dfloat(num_kont)
6465       return
6466       end
6467 c------------------------------------------------------------------------------
6468       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
6469       implicit real*8 (a-h,o-z)
6470       include 'DIMENSIONS'
6471       integer dimen1,dimen2,atom,indx
6472       double precision buffer(dimen1,dimen2)
6473       double precision zapas
6474       common /contacts_hb/ zapas(3,20,maxres,7),
6475      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6476      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6477       num_kont=buffer(1,indx+26)
6478       num_kont_old=num_cont_hb(atom)
6479       num_cont_hb(atom)=num_kont+num_kont_old
6480       do i=1,num_kont
6481         ii=i+num_kont_old
6482         do k=1,7
6483           do j=1,3
6484             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
6485           enddo ! j
6486         enddo ! k
6487         facont_hb(ii,atom)=buffer(i,indx+22)
6488         ees0p(ii,atom)=buffer(i,indx+23)
6489         ees0m(ii,atom)=buffer(i,indx+24)
6490         jcont_hb(ii,atom)=buffer(i,indx+25)
6491       enddo ! i
6492       return
6493       end
6494 c------------------------------------------------------------------------------
6495 #endif
6496       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6497 C This subroutine calculates multi-body contributions to hydrogen-bonding
6498       implicit real*8 (a-h,o-z)
6499       include 'DIMENSIONS'
6500       include 'DIMENSIONS.ZSCOPT'
6501       include 'COMMON.IOUNITS'
6502 #ifdef MPL
6503       include 'COMMON.INFO'
6504 #endif
6505       include 'COMMON.FFIELD'
6506       include 'COMMON.DERIV'
6507       include 'COMMON.INTERACT'
6508       include 'COMMON.CONTACTS'
6509 #ifdef MPL
6510       parameter (max_cont=maxconts)
6511       parameter (max_dim=2*(8*3+2))
6512       parameter (msglen1=max_cont*max_dim*4)
6513       parameter (msglen2=2*msglen1)
6514       integer source,CorrelType,CorrelID,Error
6515       double precision buffer(max_cont,max_dim)
6516 #endif
6517       double precision gx(3),gx1(3)
6518       logical lprn,ldone
6519
6520 C Set lprn=.true. for debugging
6521       lprn=.false.
6522 #ifdef MPL
6523       n_corr=0
6524       n_corr1=0
6525       if (fgProcs.le.1) goto 30
6526       if (lprn) then
6527         write (iout,'(a)') 'Contact function values:'
6528         do i=nnt,nct-2
6529           write (iout,'(2i3,50(1x,i2,f5.2))')
6530      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6531      &    j=1,num_cont_hb(i))
6532         enddo
6533       endif
6534 C Caution! Following code assumes that electrostatic interactions concerning
6535 C a given atom are split among at most two processors!
6536       CorrelType=477
6537       CorrelID=MyID+1
6538       ldone=.false.
6539       do i=1,max_cont
6540         do j=1,max_dim
6541           buffer(i,j)=0.0D0
6542         enddo
6543       enddo
6544       mm=mod(MyRank,2)
6545 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6546       if (mm) 20,20,10
6547    10 continue
6548 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6549       if (MyRank.gt.0) then
6550 C Send correlation contributions to the preceding processor
6551         msglen=msglen1
6552         nn=num_cont_hb(iatel_s)
6553         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6554 cd      write (iout,*) 'The BUFFER array:'
6555 cd      do i=1,nn
6556 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6557 cd      enddo
6558         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6559           msglen=msglen2
6560             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6561 C Clear the contacts of the atom passed to the neighboring processor
6562         nn=num_cont_hb(iatel_s+1)
6563 cd      do i=1,nn
6564 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6565 cd      enddo
6566             num_cont_hb(iatel_s)=0
6567         endif
6568 cd      write (iout,*) 'Processor ',MyID,MyRank,
6569 cd   & ' is sending correlation contribution to processor',MyID-1,
6570 cd   & ' msglen=',msglen
6571 cd      write (*,*) 'Processor ',MyID,MyRank,
6572 cd   & ' is sending correlation contribution to processor',MyID-1,
6573 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6574         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6575 cd      write (iout,*) 'Processor ',MyID,
6576 cd   & ' has sent correlation contribution to processor',MyID-1,
6577 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6578 cd      write (*,*) 'Processor ',MyID,
6579 cd   & ' has sent correlation contribution to processor',MyID-1,
6580 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6581         msglen=msglen1
6582       endif ! (MyRank.gt.0)
6583       if (ldone) goto 30
6584       ldone=.true.
6585    20 continue
6586 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6587       if (MyRank.lt.fgProcs-1) then
6588 C Receive correlation contributions from the next processor
6589         msglen=msglen1
6590         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6591 cd      write (iout,*) 'Processor',MyID,
6592 cd   & ' is receiving correlation contribution from processor',MyID+1,
6593 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6594 cd      write (*,*) 'Processor',MyID,
6595 cd   & ' is receiving correlation contribution from processor',MyID+1,
6596 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6597         nbytes=-1
6598         do while (nbytes.le.0)
6599           call mp_probe(MyID+1,CorrelType,nbytes)
6600         enddo
6601 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6602         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6603 cd      write (iout,*) 'Processor',MyID,
6604 cd   & ' has received correlation contribution from processor',MyID+1,
6605 cd   & ' msglen=',msglen,' nbytes=',nbytes
6606 cd      write (iout,*) 'The received BUFFER array:'
6607 cd      do i=1,max_cont
6608 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6609 cd      enddo
6610         if (msglen.eq.msglen1) then
6611           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6612         else if (msglen.eq.msglen2)  then
6613           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6614           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6615         else
6616           write (iout,*)
6617      & 'ERROR!!!! message length changed while processing correlations.'
6618           write (*,*)
6619      & 'ERROR!!!! message length changed while processing correlations.'
6620           call mp_stopall(Error)
6621         endif ! msglen.eq.msglen1
6622       endif ! MyRank.lt.fgProcs-1
6623       if (ldone) goto 30
6624       ldone=.true.
6625       goto 10
6626    30 continue
6627 #endif
6628       if (lprn) then
6629         write (iout,'(a)') 'Contact function values:'
6630         do i=nnt,nct-2
6631           write (iout,'(2i3,50(1x,i2,f5.2))')
6632      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6633      &    j=1,num_cont_hb(i))
6634         enddo
6635       endif
6636       ecorr=0.0D0
6637 C Remove the loop below after debugging !!!
6638       do i=nnt,nct
6639         do j=1,3
6640           gradcorr(j,i)=0.0D0
6641           gradxorr(j,i)=0.0D0
6642         enddo
6643       enddo
6644 C Calculate the local-electrostatic correlation terms
6645       do i=iatel_s,iatel_e+1
6646         i1=i+1
6647         num_conti=num_cont_hb(i)
6648         num_conti1=num_cont_hb(i+1)
6649         do jj=1,num_conti
6650           j=jcont_hb(jj,i)
6651           do kk=1,num_conti1
6652             j1=jcont_hb(kk,i1)
6653 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6654 c     &         ' jj=',jj,' kk=',kk
6655             if (j1.eq.j+1 .or. j1.eq.j-1) then
6656 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6657 C The system gains extra energy.
6658               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6659               n_corr=n_corr+1
6660             else if (j1.eq.j) then
6661 C Contacts I-J and I-(J+1) occur simultaneously.
6662 C The system loses extra energy.
6663 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6664             endif
6665           enddo ! kk
6666           do kk=1,num_conti
6667             j1=jcont_hb(kk,i)
6668 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6669 c    &         ' jj=',jj,' kk=',kk
6670             if (j1.eq.j+1) then
6671 C Contacts I-J and (I+1)-J occur simultaneously.
6672 C The system loses extra energy.
6673 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6674             endif ! j1==j+1
6675           enddo ! kk
6676         enddo ! jj
6677       enddo ! i
6678       return
6679       end
6680 c------------------------------------------------------------------------------
6681       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6682      &  n_corr1)
6683 C This subroutine calculates multi-body contributions to hydrogen-bonding
6684       implicit real*8 (a-h,o-z)
6685       include 'DIMENSIONS'
6686       include 'DIMENSIONS.ZSCOPT'
6687       include 'COMMON.IOUNITS'
6688 #ifdef MPL
6689       include 'COMMON.INFO'
6690 #endif
6691       include 'COMMON.FFIELD'
6692       include 'COMMON.DERIV'
6693       include 'COMMON.INTERACT'
6694       include 'COMMON.CONTACTS'
6695 #ifdef MPL
6696       parameter (max_cont=maxconts)
6697       parameter (max_dim=2*(8*3+2))
6698       parameter (msglen1=max_cont*max_dim*4)
6699       parameter (msglen2=2*msglen1)
6700       integer source,CorrelType,CorrelID,Error
6701       double precision buffer(max_cont,max_dim)
6702 #endif
6703       double precision gx(3),gx1(3)
6704       logical lprn,ldone
6705
6706 C Set lprn=.true. for debugging
6707       lprn=.false.
6708       eturn6=0.0d0
6709 #ifdef MPL
6710       n_corr=0
6711       n_corr1=0
6712       if (fgProcs.le.1) goto 30
6713       if (lprn) then
6714         write (iout,'(a)') 'Contact function values:'
6715         do i=nnt,nct-2
6716           write (iout,'(2i3,50(1x,i2,f5.2))')
6717      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6718      &    j=1,num_cont_hb(i))
6719         enddo
6720       endif
6721 C Caution! Following code assumes that electrostatic interactions concerning
6722 C a given atom are split among at most two processors!
6723       CorrelType=477
6724       CorrelID=MyID+1
6725       ldone=.false.
6726       do i=1,max_cont
6727         do j=1,max_dim
6728           buffer(i,j)=0.0D0
6729         enddo
6730       enddo
6731       mm=mod(MyRank,2)
6732 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6733       if (mm) 20,20,10
6734    10 continue
6735 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6736       if (MyRank.gt.0) then
6737 C Send correlation contributions to the preceding processor
6738         msglen=msglen1
6739         nn=num_cont_hb(iatel_s)
6740         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6741 cd      write (iout,*) 'The BUFFER array:'
6742 cd      do i=1,nn
6743 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6744 cd      enddo
6745         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6746           msglen=msglen2
6747             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6748 C Clear the contacts of the atom passed to the neighboring processor
6749         nn=num_cont_hb(iatel_s+1)
6750 cd      do i=1,nn
6751 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6752 cd      enddo
6753             num_cont_hb(iatel_s)=0
6754         endif
6755 cd      write (iout,*) 'Processor ',MyID,MyRank,
6756 cd   & ' is sending correlation contribution to processor',MyID-1,
6757 cd   & ' msglen=',msglen
6758 cd      write (*,*) 'Processor ',MyID,MyRank,
6759 cd   & ' is sending correlation contribution to processor',MyID-1,
6760 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6761         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6762 cd      write (iout,*) 'Processor ',MyID,
6763 cd   & ' has sent correlation contribution to processor',MyID-1,
6764 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6765 cd      write (*,*) 'Processor ',MyID,
6766 cd   & ' has sent correlation contribution to processor',MyID-1,
6767 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6768         msglen=msglen1
6769       endif ! (MyRank.gt.0)
6770       if (ldone) goto 30
6771       ldone=.true.
6772    20 continue
6773 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6774       if (MyRank.lt.fgProcs-1) then
6775 C Receive correlation contributions from the next processor
6776         msglen=msglen1
6777         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6778 cd      write (iout,*) 'Processor',MyID,
6779 cd   & ' is receiving correlation contribution from processor',MyID+1,
6780 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6781 cd      write (*,*) 'Processor',MyID,
6782 cd   & ' is receiving correlation contribution from processor',MyID+1,
6783 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6784         nbytes=-1
6785         do while (nbytes.le.0)
6786           call mp_probe(MyID+1,CorrelType,nbytes)
6787         enddo
6788 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6789         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6790 cd      write (iout,*) 'Processor',MyID,
6791 cd   & ' has received correlation contribution from processor',MyID+1,
6792 cd   & ' msglen=',msglen,' nbytes=',nbytes
6793 cd      write (iout,*) 'The received BUFFER array:'
6794 cd      do i=1,max_cont
6795 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6796 cd      enddo
6797         if (msglen.eq.msglen1) then
6798           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6799         else if (msglen.eq.msglen2)  then
6800           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6801           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6802         else
6803           write (iout,*)
6804      & 'ERROR!!!! message length changed while processing correlations.'
6805           write (*,*)
6806      & 'ERROR!!!! message length changed while processing correlations.'
6807           call mp_stopall(Error)
6808         endif ! msglen.eq.msglen1
6809       endif ! MyRank.lt.fgProcs-1
6810       if (ldone) goto 30
6811       ldone=.true.
6812       goto 10
6813    30 continue
6814 #endif
6815       if (lprn) then
6816         write (iout,'(a)') 'Contact function values:'
6817         do i=nnt,nct-2
6818           write (iout,'(2i3,50(1x,i2,f5.2))')
6819      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6820      &    j=1,num_cont_hb(i))
6821         enddo
6822       endif
6823       ecorr=0.0D0
6824       ecorr5=0.0d0
6825       ecorr6=0.0d0
6826 C Remove the loop below after debugging !!!
6827       do i=nnt,nct
6828         do j=1,3
6829           gradcorr(j,i)=0.0D0
6830           gradxorr(j,i)=0.0D0
6831         enddo
6832       enddo
6833 C Calculate the dipole-dipole interaction energies
6834       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6835       do i=iatel_s,iatel_e+1
6836         num_conti=num_cont_hb(i)
6837         do jj=1,num_conti
6838           j=jcont_hb(jj,i)
6839           call dipole(i,j,jj)
6840         enddo
6841       enddo
6842       endif
6843 C Calculate the local-electrostatic correlation terms
6844       do i=iatel_s,iatel_e+1
6845         i1=i+1
6846         num_conti=num_cont_hb(i)
6847         num_conti1=num_cont_hb(i+1)
6848         do jj=1,num_conti
6849           j=jcont_hb(jj,i)
6850           do kk=1,num_conti1
6851             j1=jcont_hb(kk,i1)
6852 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6853 c     &         ' jj=',jj,' kk=',kk
6854             if (j1.eq.j+1 .or. j1.eq.j-1) then
6855 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6856 C The system gains extra energy.
6857               n_corr=n_corr+1
6858               sqd1=dsqrt(d_cont(jj,i))
6859               sqd2=dsqrt(d_cont(kk,i1))
6860               sred_geom = sqd1*sqd2
6861               IF (sred_geom.lt.cutoff_corr) THEN
6862                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6863      &            ekont,fprimcont)
6864 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6865 c     &         ' jj=',jj,' kk=',kk
6866                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6867                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6868                 do l=1,3
6869                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6870                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6871                 enddo
6872                 n_corr1=n_corr1+1
6873 cd               write (iout,*) 'sred_geom=',sred_geom,
6874 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6875                 call calc_eello(i,j,i+1,j1,jj,kk)
6876                 if (wcorr4.gt.0.0d0)
6877      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6878                 if (wcorr5.gt.0.0d0)
6879      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6880 c                print *,"wcorr5",ecorr5
6881 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6882 cd                write(2,*)'ijkl',i,j,i+1,j1
6883                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6884      &               .or. wturn6.eq.0.0d0))then
6885 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6886                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6887 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6888 cd     &            'ecorr6=',ecorr6
6889 cd                write (iout,'(4e15.5)') sred_geom,
6890 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6891 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6892 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6893                 else if (wturn6.gt.0.0d0
6894      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6895 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6896                   eturn6=eturn6+eello_turn6(i,jj,kk)
6897 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6898                 endif
6899               ENDIF
6900 1111          continue
6901             else if (j1.eq.j) then
6902 C Contacts I-J and I-(J+1) occur simultaneously.
6903 C The system loses extra energy.
6904 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6905             endif
6906           enddo ! kk
6907           do kk=1,num_conti
6908             j1=jcont_hb(kk,i)
6909 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6910 c    &         ' jj=',jj,' kk=',kk
6911             if (j1.eq.j+1) then
6912 C Contacts I-J and (I+1)-J occur simultaneously.
6913 C The system loses extra energy.
6914 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6915             endif ! j1==j+1
6916           enddo ! kk
6917         enddo ! jj
6918       enddo ! i
6919       return
6920       end
6921 c------------------------------------------------------------------------------
6922       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6923       implicit real*8 (a-h,o-z)
6924       include 'DIMENSIONS'
6925       include 'COMMON.IOUNITS'
6926       include 'COMMON.DERIV'
6927       include 'COMMON.INTERACT'
6928       include 'COMMON.CONTACTS'
6929       double precision gx(3),gx1(3)
6930       logical lprn
6931       lprn=.false.
6932       eij=facont_hb(jj,i)
6933       ekl=facont_hb(kk,k)
6934       ees0pij=ees0p(jj,i)
6935       ees0pkl=ees0p(kk,k)
6936       ees0mij=ees0m(jj,i)
6937       ees0mkl=ees0m(kk,k)
6938       ekont=eij*ekl
6939       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6940 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6941 C Following 4 lines for diagnostics.
6942 cd    ees0pkl=0.0D0
6943 cd    ees0pij=1.0D0
6944 cd    ees0mkl=0.0D0
6945 cd    ees0mij=1.0D0
6946 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6947 c    &   ' and',k,l
6948 c     write (iout,*)'Contacts have occurred for peptide groups',
6949 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6950 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6951 C Calculate the multi-body contribution to energy.
6952       ecorr=ecorr+ekont*ees
6953       if (calc_grad) then
6954 C Calculate multi-body contributions to the gradient.
6955       do ll=1,3
6956         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6957         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6958      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6959      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6960         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6961      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6962      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6963         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6964         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6965      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6966      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6967         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6968      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6969      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6970       enddo
6971       do m=i+1,j-1
6972         do ll=1,3
6973           gradcorr(ll,m)=gradcorr(ll,m)+
6974      &     ees*ekl*gacont_hbr(ll,jj,i)-
6975      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6976      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6977         enddo
6978       enddo
6979       do m=k+1,l-1
6980         do ll=1,3
6981           gradcorr(ll,m)=gradcorr(ll,m)+
6982      &     ees*eij*gacont_hbr(ll,kk,k)-
6983      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6984      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6985         enddo
6986       enddo
6987       endif
6988       ehbcorr=ekont*ees
6989       return
6990       end
6991 C---------------------------------------------------------------------------
6992       subroutine dipole(i,j,jj)
6993       implicit real*8 (a-h,o-z)
6994       include 'DIMENSIONS'
6995       include 'DIMENSIONS.ZSCOPT'
6996       include 'COMMON.IOUNITS'
6997       include 'COMMON.CHAIN'
6998       include 'COMMON.FFIELD'
6999       include 'COMMON.DERIV'
7000       include 'COMMON.INTERACT'
7001       include 'COMMON.CONTACTS'
7002       include 'COMMON.TORSION'
7003       include 'COMMON.VAR'
7004       include 'COMMON.GEO'
7005       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7006      &  auxmat(2,2)
7007       iti1 = itortyp(itype(i+1))
7008       if (j.lt.nres-1) then
7009         itj1 = itortyp(itype(j+1))
7010       else
7011         itj1=ntortyp+1
7012       endif
7013       do iii=1,2
7014         dipi(iii,1)=Ub2(iii,i)
7015         dipderi(iii)=Ub2der(iii,i)
7016         dipi(iii,2)=b1(iii,i+1)
7017         dipj(iii,1)=Ub2(iii,j)
7018         dipderj(iii)=Ub2der(iii,j)
7019         dipj(iii,2)=b1(iii,j+1)
7020       enddo
7021       kkk=0
7022       do iii=1,2
7023         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7024         do jjj=1,2
7025           kkk=kkk+1
7026           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7027         enddo
7028       enddo
7029       if (.not.calc_grad) return
7030       do kkk=1,5
7031         do lll=1,3
7032           mmm=0
7033           do iii=1,2
7034             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7035      &        auxvec(1))
7036             do jjj=1,2
7037               mmm=mmm+1
7038               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7039             enddo
7040           enddo
7041         enddo
7042       enddo
7043       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7044       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7045       do iii=1,2
7046         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7047       enddo
7048       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7049       do iii=1,2
7050         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7051       enddo
7052       return
7053       end
7054 C---------------------------------------------------------------------------
7055       subroutine calc_eello(i,j,k,l,jj,kk)
7056 C
7057 C This subroutine computes matrices and vectors needed to calculate
7058 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7059 C
7060       implicit real*8 (a-h,o-z)
7061       include 'DIMENSIONS'
7062       include 'DIMENSIONS.ZSCOPT'
7063       include 'COMMON.IOUNITS'
7064       include 'COMMON.CHAIN'
7065       include 'COMMON.DERIV'
7066       include 'COMMON.INTERACT'
7067       include 'COMMON.CONTACTS'
7068       include 'COMMON.TORSION'
7069       include 'COMMON.VAR'
7070       include 'COMMON.GEO'
7071       include 'COMMON.FFIELD'
7072       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7073      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7074       logical lprn
7075       common /kutas/ lprn
7076 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7077 cd     & ' jj=',jj,' kk=',kk
7078 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7079       do iii=1,2
7080         do jjj=1,2
7081           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7082           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7083         enddo
7084       enddo
7085       call transpose2(aa1(1,1),aa1t(1,1))
7086       call transpose2(aa2(1,1),aa2t(1,1))
7087       do kkk=1,5
7088         do lll=1,3
7089           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7090      &      aa1tder(1,1,lll,kkk))
7091           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7092      &      aa2tder(1,1,lll,kkk))
7093         enddo
7094       enddo
7095       if (l.eq.j+1) then
7096 C parallel orientation of the two CA-CA-CA frames.
7097         if (i.gt.1) then
7098           iti=itortyp(itype(i))
7099         else
7100           iti=ntortyp+1
7101         endif
7102         itk1=itortyp(itype(k+1))
7103         itj=itortyp(itype(j))
7104         if (l.lt.nres-1) then
7105           itl1=itortyp(itype(l+1))
7106         else
7107           itl1=ntortyp+1
7108         endif
7109 C A1 kernel(j+1) A2T
7110 cd        do iii=1,2
7111 cd          write (iout,'(3f10.5,5x,3f10.5)')
7112 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7113 cd        enddo
7114         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7115      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7116      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7117 C Following matrices are needed only for 6-th order cumulants
7118         IF (wcorr6.gt.0.0d0) THEN
7119         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7120      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7121      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7122         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7123      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7124      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7125      &   ADtEAderx(1,1,1,1,1,1))
7126         lprn=.false.
7127         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7128      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7129      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7130      &   ADtEA1derx(1,1,1,1,1,1))
7131         ENDIF
7132 C End 6-th order cumulants
7133 cd        lprn=.false.
7134 cd        if (lprn) then
7135 cd        write (2,*) 'In calc_eello6'
7136 cd        do iii=1,2
7137 cd          write (2,*) 'iii=',iii
7138 cd          do kkk=1,5
7139 cd            write (2,*) 'kkk=',kkk
7140 cd            do jjj=1,2
7141 cd              write (2,'(3(2f10.5),5x)')
7142 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7143 cd            enddo
7144 cd          enddo
7145 cd        enddo
7146 cd        endif
7147         call transpose2(EUgder(1,1,k),auxmat(1,1))
7148         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7149         call transpose2(EUg(1,1,k),auxmat(1,1))
7150         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7151         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
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,1),
7156      &          EAEAderx(1,1,lll,kkk,iii,1))
7157             enddo
7158           enddo
7159         enddo
7160 C A1T kernel(i+1) A2
7161         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7162      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7163      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7164 C Following matrices are needed only for 6-th order cumulants
7165         IF (wcorr6.gt.0.0d0) THEN
7166         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7167      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7168      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7169         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7170      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7171      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7172      &   ADtEAderx(1,1,1,1,1,2))
7173         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7174      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7175      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7176      &   ADtEA1derx(1,1,1,1,1,2))
7177         ENDIF
7178 C End 6-th order cumulants
7179         call transpose2(EUgder(1,1,l),auxmat(1,1))
7180         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7181         call transpose2(EUg(1,1,l),auxmat(1,1))
7182         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7183         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7184         do iii=1,2
7185           do kkk=1,5
7186             do lll=1,3
7187               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7188      &          EAEAderx(1,1,lll,kkk,iii,2))
7189             enddo
7190           enddo
7191         enddo
7192 C AEAb1 and AEAb2
7193 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7194 C They are needed only when the fifth- or the sixth-order cumulants are
7195 C indluded.
7196         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7197         call transpose2(AEA(1,1,1),auxmat(1,1))
7198         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7199         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7200         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7201         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7202         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7203         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7204         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7205         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7206         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7207         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7208         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7209         call transpose2(AEA(1,1,2),auxmat(1,1))
7210         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
7211         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7212         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7213         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7214         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
7215         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7216         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
7217         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
7218         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7219         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7220         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7221 C Calculate the Cartesian derivatives of the vectors.
7222         do iii=1,2
7223           do kkk=1,5
7224             do lll=1,3
7225               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7226               call matvec2(auxmat(1,1),b1(1,i),
7227      &          AEAb1derx(1,lll,kkk,iii,1,1))
7228               call matvec2(auxmat(1,1),Ub2(1,i),
7229      &          AEAb2derx(1,lll,kkk,iii,1,1))
7230               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7231      &          AEAb1derx(1,lll,kkk,iii,2,1))
7232               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7233      &          AEAb2derx(1,lll,kkk,iii,2,1))
7234               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7235               call matvec2(auxmat(1,1),b1(1,j),
7236      &          AEAb1derx(1,lll,kkk,iii,1,2))
7237               call matvec2(auxmat(1,1),Ub2(1,j),
7238      &          AEAb2derx(1,lll,kkk,iii,1,2))
7239               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7240      &          AEAb1derx(1,lll,kkk,iii,2,2))
7241               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7242      &          AEAb2derx(1,lll,kkk,iii,2,2))
7243             enddo
7244           enddo
7245         enddo
7246         ENDIF
7247 C End vectors
7248       else
7249 C Antiparallel orientation of the two CA-CA-CA frames.
7250         if (i.gt.1) then
7251           iti=itortyp(itype(i))
7252         else
7253           iti=ntortyp+1
7254         endif
7255         itk1=itortyp(itype(k+1))
7256         itl=itortyp(itype(l))
7257         itj=itortyp(itype(j))
7258         if (j.lt.nres-1) then
7259           itj1=itortyp(itype(j+1))
7260         else
7261           itj1=ntortyp+1
7262         endif
7263 C A2 kernel(j-1)T A1T
7264         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7265      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7266      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7267 C Following matrices are needed only for 6-th order cumulants
7268         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7269      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7270         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7271      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7272      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7273         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7274      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7275      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7276      &   ADtEAderx(1,1,1,1,1,1))
7277         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7278      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7279      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7280      &   ADtEA1derx(1,1,1,1,1,1))
7281         ENDIF
7282 C End 6-th order cumulants
7283         call transpose2(EUgder(1,1,k),auxmat(1,1))
7284         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7285         call transpose2(EUg(1,1,k),auxmat(1,1))
7286         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7287         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7288         do iii=1,2
7289           do kkk=1,5
7290             do lll=1,3
7291               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7292      &          EAEAderx(1,1,lll,kkk,iii,1))
7293             enddo
7294           enddo
7295         enddo
7296 C A2T kernel(i+1)T A1
7297         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7298      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7299      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7300 C Following matrices are needed only for 6-th order cumulants
7301         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7302      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7303         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7304      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7305      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7306         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7307      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7308      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7309      &   ADtEAderx(1,1,1,1,1,2))
7310         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7311      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7312      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7313      &   ADtEA1derx(1,1,1,1,1,2))
7314         ENDIF
7315 C End 6-th order cumulants
7316         call transpose2(EUgder(1,1,j),auxmat(1,1))
7317         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7318         call transpose2(EUg(1,1,j),auxmat(1,1))
7319         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7320         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7321         do iii=1,2
7322           do kkk=1,5
7323             do lll=1,3
7324               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7325      &          EAEAderx(1,1,lll,kkk,iii,2))
7326             enddo
7327           enddo
7328         enddo
7329 C AEAb1 and AEAb2
7330 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7331 C They are needed only when the fifth- or the sixth-order cumulants are
7332 C indluded.
7333         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7334      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7335         call transpose2(AEA(1,1,1),auxmat(1,1))
7336         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7337         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7338         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7339         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7340         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7341         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7342         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7343         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7344         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7345         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7346         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7347         call transpose2(AEA(1,1,2),auxmat(1,1))
7348         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7349         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7350         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7351         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7352         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7353         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7354         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7355         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7356         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7357         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7358         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7359 C Calculate the Cartesian derivatives of the vectors.
7360         do iii=1,2
7361           do kkk=1,5
7362             do lll=1,3
7363               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7364               call matvec2(auxmat(1,1),b1(1,i),
7365      &          AEAb1derx(1,lll,kkk,iii,1,1))
7366               call matvec2(auxmat(1,1),Ub2(1,i),
7367      &          AEAb2derx(1,lll,kkk,iii,1,1))
7368               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7369      &          AEAb1derx(1,lll,kkk,iii,2,1))
7370               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7371      &          AEAb2derx(1,lll,kkk,iii,2,1))
7372               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7373               call matvec2(auxmat(1,1),b1(1,l),
7374      &          AEAb1derx(1,lll,kkk,iii,1,2))
7375               call matvec2(auxmat(1,1),Ub2(1,l),
7376      &          AEAb2derx(1,lll,kkk,iii,1,2))
7377               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7378      &          AEAb1derx(1,lll,kkk,iii,2,2))
7379               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7380      &          AEAb2derx(1,lll,kkk,iii,2,2))
7381             enddo
7382           enddo
7383         enddo
7384         ENDIF
7385 C End vectors
7386       endif
7387       return
7388       end
7389 C---------------------------------------------------------------------------
7390       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7391      &  KK,KKderg,AKA,AKAderg,AKAderx)
7392       implicit none
7393       integer nderg
7394       logical transp
7395       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7396      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7397      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7398       integer iii,kkk,lll
7399       integer jjj,mmm
7400       logical lprn
7401       common /kutas/ lprn
7402       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7403       do iii=1,nderg
7404         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7405      &    AKAderg(1,1,iii))
7406       enddo
7407 cd      if (lprn) write (2,*) 'In kernel'
7408       do kkk=1,5
7409 cd        if (lprn) write (2,*) 'kkk=',kkk
7410         do lll=1,3
7411           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7412      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7413 cd          if (lprn) then
7414 cd            write (2,*) 'lll=',lll
7415 cd            write (2,*) 'iii=1'
7416 cd            do jjj=1,2
7417 cd              write (2,'(3(2f10.5),5x)')
7418 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7419 cd            enddo
7420 cd          endif
7421           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7422      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7423 cd          if (lprn) then
7424 cd            write (2,*) 'lll=',lll
7425 cd            write (2,*) 'iii=2'
7426 cd            do jjj=1,2
7427 cd              write (2,'(3(2f10.5),5x)')
7428 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7429 cd            enddo
7430 cd          endif
7431         enddo
7432       enddo
7433       return
7434       end
7435 C---------------------------------------------------------------------------
7436       double precision function eello4(i,j,k,l,jj,kk)
7437       implicit real*8 (a-h,o-z)
7438       include 'DIMENSIONS'
7439       include 'DIMENSIONS.ZSCOPT'
7440       include 'COMMON.IOUNITS'
7441       include 'COMMON.CHAIN'
7442       include 'COMMON.DERIV'
7443       include 'COMMON.INTERACT'
7444       include 'COMMON.CONTACTS'
7445       include 'COMMON.TORSION'
7446       include 'COMMON.VAR'
7447       include 'COMMON.GEO'
7448       double precision pizda(2,2),ggg1(3),ggg2(3)
7449 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7450 cd        eello4=0.0d0
7451 cd        return
7452 cd      endif
7453 cd      print *,'eello4:',i,j,k,l,jj,kk
7454 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7455 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7456 cold      eij=facont_hb(jj,i)
7457 cold      ekl=facont_hb(kk,k)
7458 cold      ekont=eij*ekl
7459       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7460       if (calc_grad) then
7461 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7462       gcorr_loc(k-1)=gcorr_loc(k-1)
7463      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7464       if (l.eq.j+1) then
7465         gcorr_loc(l-1)=gcorr_loc(l-1)
7466      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7467       else
7468         gcorr_loc(j-1)=gcorr_loc(j-1)
7469      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7470       endif
7471       do iii=1,2
7472         do kkk=1,5
7473           do lll=1,3
7474             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7475      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7476 cd            derx(lll,kkk,iii)=0.0d0
7477           enddo
7478         enddo
7479       enddo
7480 cd      gcorr_loc(l-1)=0.0d0
7481 cd      gcorr_loc(j-1)=0.0d0
7482 cd      gcorr_loc(k-1)=0.0d0
7483 cd      eel4=1.0d0
7484 cd      write (iout,*)'Contacts have occurred for peptide groups',
7485 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7486 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7487       if (j.lt.nres-1) then
7488         j1=j+1
7489         j2=j-1
7490       else
7491         j1=j-1
7492         j2=j-2
7493       endif
7494       if (l.lt.nres-1) then
7495         l1=l+1
7496         l2=l-1
7497       else
7498         l1=l-1
7499         l2=l-2
7500       endif
7501       do ll=1,3
7502 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
7503         ggg1(ll)=eel4*g_contij(ll,1)
7504         ggg2(ll)=eel4*g_contij(ll,2)
7505         ghalf=0.5d0*ggg1(ll)
7506 cd        ghalf=0.0d0
7507         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
7508         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7509         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
7510         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7511 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
7512         ghalf=0.5d0*ggg2(ll)
7513 cd        ghalf=0.0d0
7514         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
7515         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7516         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
7517         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7518       enddo
7519 cd      goto 1112
7520       do m=i+1,j-1
7521         do ll=1,3
7522 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
7523           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7524         enddo
7525       enddo
7526       do m=k+1,l-1
7527         do ll=1,3
7528 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
7529           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7530         enddo
7531       enddo
7532 1112  continue
7533       do m=i+2,j2
7534         do ll=1,3
7535           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7536         enddo
7537       enddo
7538       do m=k+2,l2
7539         do ll=1,3
7540           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7541         enddo
7542       enddo
7543 cd      do iii=1,nres-3
7544 cd        write (2,*) iii,gcorr_loc(iii)
7545 cd      enddo
7546       endif
7547       eello4=ekont*eel4
7548 cd      write (2,*) 'ekont',ekont
7549 cd      write (iout,*) 'eello4',ekont*eel4
7550       return
7551       end
7552 C---------------------------------------------------------------------------
7553       double precision function eello5(i,j,k,l,jj,kk)
7554       implicit real*8 (a-h,o-z)
7555       include 'DIMENSIONS'
7556       include 'DIMENSIONS.ZSCOPT'
7557       include 'COMMON.IOUNITS'
7558       include 'COMMON.CHAIN'
7559       include 'COMMON.DERIV'
7560       include 'COMMON.INTERACT'
7561       include 'COMMON.CONTACTS'
7562       include 'COMMON.TORSION'
7563       include 'COMMON.VAR'
7564       include 'COMMON.GEO'
7565       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7566       double precision ggg1(3),ggg2(3)
7567 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7568 C                                                                              C
7569 C                            Parallel chains                                   C
7570 C                                                                              C
7571 C          o             o                   o             o                   C
7572 C         /l\           / \             \   / \           / \   /              C
7573 C        /   \         /   \             \ /   \         /   \ /               C
7574 C       j| o |l1       | o |              o| o |         | o |o                C
7575 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7576 C      \i/   \         /   \ /             /   \         /   \                 C
7577 C       o    k1             o                                                  C
7578 C         (I)          (II)                (III)          (IV)                 C
7579 C                                                                              C
7580 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7581 C                                                                              C
7582 C                            Antiparallel chains                               C
7583 C                                                                              C
7584 C          o             o                   o             o                   C
7585 C         /j\           / \             \   / \           / \   /              C
7586 C        /   \         /   \             \ /   \         /   \ /               C
7587 C      j1| o |l        | o |              o| o |         | o |o                C
7588 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7589 C      \i/   \         /   \ /             /   \         /   \                 C
7590 C       o     k1            o                                                  C
7591 C         (I)          (II)                (III)          (IV)                 C
7592 C                                                                              C
7593 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7594 C                                                                              C
7595 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7596 C                                                                              C
7597 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7598 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7599 cd        eello5=0.0d0
7600 cd        return
7601 cd      endif
7602 cd      write (iout,*)
7603 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7604 cd     &   ' and',k,l
7605       itk=itortyp(itype(k))
7606       itl=itortyp(itype(l))
7607       itj=itortyp(itype(j))
7608       eello5_1=0.0d0
7609       eello5_2=0.0d0
7610       eello5_3=0.0d0
7611       eello5_4=0.0d0
7612 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7613 cd     &   eel5_3_num,eel5_4_num)
7614       do iii=1,2
7615         do kkk=1,5
7616           do lll=1,3
7617             derx(lll,kkk,iii)=0.0d0
7618           enddo
7619         enddo
7620       enddo
7621 cd      eij=facont_hb(jj,i)
7622 cd      ekl=facont_hb(kk,k)
7623 cd      ekont=eij*ekl
7624 cd      write (iout,*)'Contacts have occurred for peptide groups',
7625 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7626 cd      goto 1111
7627 C Contribution from the graph I.
7628 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7629 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7630       call transpose2(EUg(1,1,k),auxmat(1,1))
7631       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7632       vv(1)=pizda(1,1)-pizda(2,2)
7633       vv(2)=pizda(1,2)+pizda(2,1)
7634       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7635      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7636       if (calc_grad) then
7637 C Explicit gradient in virtual-dihedral angles.
7638       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7639      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7640      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7641       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7642       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7643       vv(1)=pizda(1,1)-pizda(2,2)
7644       vv(2)=pizda(1,2)+pizda(2,1)
7645       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7646      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7647      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7648       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7649       vv(1)=pizda(1,1)-pizda(2,2)
7650       vv(2)=pizda(1,2)+pizda(2,1)
7651       if (l.eq.j+1) then
7652         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7653      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7654      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7655       else
7656         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7657      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7658      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7659       endif
7660 C Cartesian gradient
7661       do iii=1,2
7662         do kkk=1,5
7663           do lll=1,3
7664             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7665      &        pizda(1,1))
7666             vv(1)=pizda(1,1)-pizda(2,2)
7667             vv(2)=pizda(1,2)+pizda(2,1)
7668             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7669      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7670      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7671           enddo
7672         enddo
7673       enddo
7674 c      goto 1112
7675       endif
7676 c1111  continue
7677 C Contribution from graph II
7678       call transpose2(EE(1,1,itk),auxmat(1,1))
7679       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7680       vv(1)=pizda(1,1)+pizda(2,2)
7681       vv(2)=pizda(2,1)-pizda(1,2)
7682       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7683      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7684       if (calc_grad) then
7685 C Explicit gradient in virtual-dihedral angles.
7686       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7687      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7688       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7689       vv(1)=pizda(1,1)+pizda(2,2)
7690       vv(2)=pizda(2,1)-pizda(1,2)
7691       if (l.eq.j+1) then
7692         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7693      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7694      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7695       else
7696         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7697      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7698      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7699       endif
7700 C Cartesian gradient
7701       do iii=1,2
7702         do kkk=1,5
7703           do lll=1,3
7704             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7705      &        pizda(1,1))
7706             vv(1)=pizda(1,1)+pizda(2,2)
7707             vv(2)=pizda(2,1)-pizda(1,2)
7708             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7709      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7710      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7711           enddo
7712         enddo
7713       enddo
7714 cd      goto 1112
7715       endif
7716 cd1111  continue
7717       if (l.eq.j+1) then
7718 cd        goto 1110
7719 C Parallel orientation
7720 C Contribution from graph III
7721         call transpose2(EUg(1,1,l),auxmat(1,1))
7722         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7723         vv(1)=pizda(1,1)-pizda(2,2)
7724         vv(2)=pizda(1,2)+pizda(2,1)
7725         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7726      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7727         if (calc_grad) then
7728 C Explicit gradient in virtual-dihedral angles.
7729         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7730      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7731      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7732         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7733         vv(1)=pizda(1,1)-pizda(2,2)
7734         vv(2)=pizda(1,2)+pizda(2,1)
7735         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7736      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7737      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7738         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7739         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7740         vv(1)=pizda(1,1)-pizda(2,2)
7741         vv(2)=pizda(1,2)+pizda(2,1)
7742         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7743      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7744      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7745 C Cartesian gradient
7746         do iii=1,2
7747           do kkk=1,5
7748             do lll=1,3
7749               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7750      &          pizda(1,1))
7751               vv(1)=pizda(1,1)-pizda(2,2)
7752               vv(2)=pizda(1,2)+pizda(2,1)
7753               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7754      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7755      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7756             enddo
7757           enddo
7758         enddo
7759 cd        goto 1112
7760         endif
7761 C Contribution from graph IV
7762 cd1110    continue
7763         call transpose2(EE(1,1,itl),auxmat(1,1))
7764         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7765         vv(1)=pizda(1,1)+pizda(2,2)
7766         vv(2)=pizda(2,1)-pizda(1,2)
7767         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7768      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7769         if (calc_grad) then
7770 C Explicit gradient in virtual-dihedral angles.
7771         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7772      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7773         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7774         vv(1)=pizda(1,1)+pizda(2,2)
7775         vv(2)=pizda(2,1)-pizda(1,2)
7776         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7777      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7778      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7779 C Cartesian gradient
7780         do iii=1,2
7781           do kkk=1,5
7782             do lll=1,3
7783               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7784      &          pizda(1,1))
7785               vv(1)=pizda(1,1)+pizda(2,2)
7786               vv(2)=pizda(2,1)-pizda(1,2)
7787               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7788      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7789      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7790             enddo
7791           enddo
7792         enddo
7793         endif
7794       else
7795 C Antiparallel orientation
7796 C Contribution from graph III
7797 c        goto 1110
7798         call transpose2(EUg(1,1,j),auxmat(1,1))
7799         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7800         vv(1)=pizda(1,1)-pizda(2,2)
7801         vv(2)=pizda(1,2)+pizda(2,1)
7802         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7803      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7804         if (calc_grad) then
7805 C Explicit gradient in virtual-dihedral angles.
7806         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7807      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7808      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7809         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7810         vv(1)=pizda(1,1)-pizda(2,2)
7811         vv(2)=pizda(1,2)+pizda(2,1)
7812         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7813      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7814      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7815         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7816         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7817         vv(1)=pizda(1,1)-pizda(2,2)
7818         vv(2)=pizda(1,2)+pizda(2,1)
7819         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7820      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7821      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7822 C Cartesian gradient
7823         do iii=1,2
7824           do kkk=1,5
7825             do lll=1,3
7826               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7827      &          pizda(1,1))
7828               vv(1)=pizda(1,1)-pizda(2,2)
7829               vv(2)=pizda(1,2)+pizda(2,1)
7830               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7831      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7832      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7833             enddo
7834           enddo
7835         enddo
7836 cd        goto 1112
7837         endif
7838 C Contribution from graph IV
7839 1110    continue
7840         call transpose2(EE(1,1,itj),auxmat(1,1))
7841         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7842         vv(1)=pizda(1,1)+pizda(2,2)
7843         vv(2)=pizda(2,1)-pizda(1,2)
7844         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7845      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7846         if (calc_grad) then
7847 C Explicit gradient in virtual-dihedral angles.
7848         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7849      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7850         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7851         vv(1)=pizda(1,1)+pizda(2,2)
7852         vv(2)=pizda(2,1)-pizda(1,2)
7853         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7854      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7855      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7856 C Cartesian gradient
7857         do iii=1,2
7858           do kkk=1,5
7859             do lll=1,3
7860               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7861      &          pizda(1,1))
7862               vv(1)=pizda(1,1)+pizda(2,2)
7863               vv(2)=pizda(2,1)-pizda(1,2)
7864               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7865      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7866      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7867             enddo
7868           enddo
7869         enddo
7870       endif
7871       endif
7872 1112  continue
7873       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7874 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7875 cd        write (2,*) 'ijkl',i,j,k,l
7876 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7877 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7878 cd      endif
7879 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7880 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7881 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7882 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7883       if (calc_grad) then
7884       if (j.lt.nres-1) then
7885         j1=j+1
7886         j2=j-1
7887       else
7888         j1=j-1
7889         j2=j-2
7890       endif
7891       if (l.lt.nres-1) then
7892         l1=l+1
7893         l2=l-1
7894       else
7895         l1=l-1
7896         l2=l-2
7897       endif
7898 cd      eij=1.0d0
7899 cd      ekl=1.0d0
7900 cd      ekont=1.0d0
7901 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7902       do ll=1,3
7903         ggg1(ll)=eel5*g_contij(ll,1)
7904         ggg2(ll)=eel5*g_contij(ll,2)
7905 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7906         ghalf=0.5d0*ggg1(ll)
7907 cd        ghalf=0.0d0
7908         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7909         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7910         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7911         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7912 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7913         ghalf=0.5d0*ggg2(ll)
7914 cd        ghalf=0.0d0
7915         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7916         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7917         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7918         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7919       enddo
7920 cd      goto 1112
7921       do m=i+1,j-1
7922         do ll=1,3
7923 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7924           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7925         enddo
7926       enddo
7927       do m=k+1,l-1
7928         do ll=1,3
7929 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7930           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7931         enddo
7932       enddo
7933 c1112  continue
7934       do m=i+2,j2
7935         do ll=1,3
7936           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7937         enddo
7938       enddo
7939       do m=k+2,l2
7940         do ll=1,3
7941           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7942         enddo
7943       enddo
7944 cd      do iii=1,nres-3
7945 cd        write (2,*) iii,g_corr5_loc(iii)
7946 cd      enddo
7947       endif
7948       eello5=ekont*eel5
7949 cd      write (2,*) 'ekont',ekont
7950 cd      write (iout,*) 'eello5',ekont*eel5
7951       return
7952       end
7953 c--------------------------------------------------------------------------
7954       double precision function eello6(i,j,k,l,jj,kk)
7955       implicit real*8 (a-h,o-z)
7956       include 'DIMENSIONS'
7957       include 'DIMENSIONS.ZSCOPT'
7958       include 'COMMON.IOUNITS'
7959       include 'COMMON.CHAIN'
7960       include 'COMMON.DERIV'
7961       include 'COMMON.INTERACT'
7962       include 'COMMON.CONTACTS'
7963       include 'COMMON.TORSION'
7964       include 'COMMON.VAR'
7965       include 'COMMON.GEO'
7966       include 'COMMON.FFIELD'
7967       double precision ggg1(3),ggg2(3)
7968 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7969 cd        eello6=0.0d0
7970 cd        return
7971 cd      endif
7972 cd      write (iout,*)
7973 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7974 cd     &   ' and',k,l
7975       eello6_1=0.0d0
7976       eello6_2=0.0d0
7977       eello6_3=0.0d0
7978       eello6_4=0.0d0
7979       eello6_5=0.0d0
7980       eello6_6=0.0d0
7981 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7982 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7983       do iii=1,2
7984         do kkk=1,5
7985           do lll=1,3
7986             derx(lll,kkk,iii)=0.0d0
7987           enddo
7988         enddo
7989       enddo
7990 cd      eij=facont_hb(jj,i)
7991 cd      ekl=facont_hb(kk,k)
7992 cd      ekont=eij*ekl
7993 cd      eij=1.0d0
7994 cd      ekl=1.0d0
7995 cd      ekont=1.0d0
7996       if (l.eq.j+1) then
7997         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7998         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7999         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8000         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8001         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8002         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8003       else
8004         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8005         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8006         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8007         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8008         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8009           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8010         else
8011           eello6_5=0.0d0
8012         endif
8013         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8014       endif
8015 C If turn contributions are considered, they will be handled separately.
8016       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8017 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
8018 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
8019 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
8020 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
8021 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
8022 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
8023 cd      goto 1112
8024       if (calc_grad) then
8025       if (j.lt.nres-1) then
8026         j1=j+1
8027         j2=j-1
8028       else
8029         j1=j-1
8030         j2=j-2
8031       endif
8032       if (l.lt.nres-1) then
8033         l1=l+1
8034         l2=l-1
8035       else
8036         l1=l-1
8037         l2=l-2
8038       endif
8039       do ll=1,3
8040         ggg1(ll)=eel6*g_contij(ll,1)
8041         ggg2(ll)=eel6*g_contij(ll,2)
8042 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8043         ghalf=0.5d0*ggg1(ll)
8044 cd        ghalf=0.0d0
8045         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
8046         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8047         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
8048         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8049         ghalf=0.5d0*ggg2(ll)
8050 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8051 cd        ghalf=0.0d0
8052         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
8053         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8054         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
8055         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8056       enddo
8057 cd      goto 1112
8058       do m=i+1,j-1
8059         do ll=1,3
8060 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8061           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8062         enddo
8063       enddo
8064       do m=k+1,l-1
8065         do ll=1,3
8066 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8067           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8068         enddo
8069       enddo
8070 1112  continue
8071       do m=i+2,j2
8072         do ll=1,3
8073           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8074         enddo
8075       enddo
8076       do m=k+2,l2
8077         do ll=1,3
8078           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8079         enddo
8080       enddo
8081 cd      do iii=1,nres-3
8082 cd        write (2,*) iii,g_corr6_loc(iii)
8083 cd      enddo
8084       endif
8085       eello6=ekont*eel6
8086 cd      write (2,*) 'ekont',ekont
8087 cd      write (iout,*) 'eello6',ekont*eel6
8088       return
8089       end
8090 c--------------------------------------------------------------------------
8091       double precision function eello6_graph1(i,j,k,l,imat,swap)
8092       implicit real*8 (a-h,o-z)
8093       include 'DIMENSIONS'
8094       include 'DIMENSIONS.ZSCOPT'
8095       include 'COMMON.IOUNITS'
8096       include 'COMMON.CHAIN'
8097       include 'COMMON.DERIV'
8098       include 'COMMON.INTERACT'
8099       include 'COMMON.CONTACTS'
8100       include 'COMMON.TORSION'
8101       include 'COMMON.VAR'
8102       include 'COMMON.GEO'
8103       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8104       logical swap
8105       logical lprn
8106       common /kutas/ lprn
8107 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8108 C                                                                              C
8109 C      Parallel       Antiparallel                                             C
8110 C                                                                              C
8111 C          o             o                                                     C
8112 C         /l\           /j\                                                    C
8113 C        /   \         /   \                                                   C
8114 C       /| o |         | o |\                                                  C
8115 C     \ j|/k\|  /   \  |/k\|l /                                                C
8116 C      \ /   \ /     \ /   \ /                                                 C
8117 C       o     o       o     o                                                  C
8118 C       i             i                                                        C
8119 C                                                                              C
8120 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8121       itk=itortyp(itype(k))
8122       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8123       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8124       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8125       call transpose2(EUgC(1,1,k),auxmat(1,1))
8126       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8127       vv1(1)=pizda1(1,1)-pizda1(2,2)
8128       vv1(2)=pizda1(1,2)+pizda1(2,1)
8129       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8130       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
8131       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
8132       s5=scalar2(vv(1),Dtobr2(1,i))
8133 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8134       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8135       if (.not. calc_grad) return
8136       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8137      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8138      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8139      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8140      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8141      & +scalar2(vv(1),Dtobr2der(1,i)))
8142       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8143       vv1(1)=pizda1(1,1)-pizda1(2,2)
8144       vv1(2)=pizda1(1,2)+pizda1(2,1)
8145       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
8146       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
8147       if (l.eq.j+1) then
8148         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8149      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8150      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8151      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8152      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8153       else
8154         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8155      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8156      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8157      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8158      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8159       endif
8160       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8161       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8162       vv1(1)=pizda1(1,1)-pizda1(2,2)
8163       vv1(2)=pizda1(1,2)+pizda1(2,1)
8164       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8165      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8166      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8167      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8168       do iii=1,2
8169         if (swap) then
8170           ind=3-iii
8171         else
8172           ind=iii
8173         endif
8174         do kkk=1,5
8175           do lll=1,3
8176             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8177             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8178             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8179             call transpose2(EUgC(1,1,k),auxmat(1,1))
8180             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8181      &        pizda1(1,1))
8182             vv1(1)=pizda1(1,1)-pizda1(2,2)
8183             vv1(2)=pizda1(1,2)+pizda1(2,1)
8184             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8185             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
8186      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
8187             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
8188      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
8189             s5=scalar2(vv(1),Dtobr2(1,i))
8190             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8191           enddo
8192         enddo
8193       enddo
8194       return
8195       end
8196 c----------------------------------------------------------------------------
8197       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8198       implicit real*8 (a-h,o-z)
8199       include 'DIMENSIONS'
8200       include 'DIMENSIONS.ZSCOPT'
8201       include 'COMMON.IOUNITS'
8202       include 'COMMON.CHAIN'
8203       include 'COMMON.DERIV'
8204       include 'COMMON.INTERACT'
8205       include 'COMMON.CONTACTS'
8206       include 'COMMON.TORSION'
8207       include 'COMMON.VAR'
8208       include 'COMMON.GEO'
8209       logical swap
8210       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8211      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8212       logical lprn
8213       common /kutas/ lprn
8214 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8215 C                                                                              C
8216 C      Parallel       Antiparallel                                             C
8217 C                                                                              C
8218 C          o             o                                                     C
8219 C     \   /l\           /j\   /                                                C
8220 C      \ /   \         /   \ /                                                 C
8221 C       o| o |         | o |o                                                  C
8222 C     \ j|/k\|      \  |/k\|l                                                  C
8223 C      \ /   \       \ /   \                                                   C
8224 C       o             o                                                        C
8225 C       i             i                                                        C
8226 C                                                                              C
8227 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8228 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8229 C AL 7/4/01 s1 would occur in the sixth-order moment,
8230 C           but not in a cluster cumulant
8231 #ifdef MOMENT
8232       s1=dip(1,jj,i)*dip(1,kk,k)
8233 #endif
8234       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8235       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8236       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8237       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8238       call transpose2(EUg(1,1,k),auxmat(1,1))
8239       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8240       vv(1)=pizda(1,1)-pizda(2,2)
8241       vv(2)=pizda(1,2)+pizda(2,1)
8242       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8243 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8244 #ifdef MOMENT
8245       eello6_graph2=-(s1+s2+s3+s4)
8246 #else
8247       eello6_graph2=-(s2+s3+s4)
8248 #endif
8249 c      eello6_graph2=-s3
8250       if (.not. calc_grad) return
8251 C Derivatives in gamma(i-1)
8252       if (i.gt.1) then
8253 #ifdef MOMENT
8254         s1=dipderg(1,jj,i)*dip(1,kk,k)
8255 #endif
8256         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8257         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8258         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8259         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8260 #ifdef MOMENT
8261         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8262 #else
8263         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8264 #endif
8265 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8266       endif
8267 C Derivatives in gamma(k-1)
8268 #ifdef MOMENT
8269       s1=dip(1,jj,i)*dipderg(1,kk,k)
8270 #endif
8271       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8272       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8273       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8274       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8275       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8276       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8277       vv(1)=pizda(1,1)-pizda(2,2)
8278       vv(2)=pizda(1,2)+pizda(2,1)
8279       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8280 #ifdef MOMENT
8281       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8282 #else
8283       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8284 #endif
8285 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8286 C Derivatives in gamma(j-1) or gamma(l-1)
8287       if (j.gt.1) then
8288 #ifdef MOMENT
8289         s1=dipderg(3,jj,i)*dip(1,kk,k)
8290 #endif
8291         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8292         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8293         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8294         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8295         vv(1)=pizda(1,1)-pizda(2,2)
8296         vv(2)=pizda(1,2)+pizda(2,1)
8297         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8298 #ifdef MOMENT
8299         if (swap) then
8300           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8301         else
8302           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8303         endif
8304 #endif
8305         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8306 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8307       endif
8308 C Derivatives in gamma(l-1) or gamma(j-1)
8309       if (l.gt.1) then
8310 #ifdef MOMENT
8311         s1=dip(1,jj,i)*dipderg(3,kk,k)
8312 #endif
8313         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8314         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8315         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8316         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8317         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8318         vv(1)=pizda(1,1)-pizda(2,2)
8319         vv(2)=pizda(1,2)+pizda(2,1)
8320         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8321 #ifdef MOMENT
8322         if (swap) then
8323           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8324         else
8325           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8326         endif
8327 #endif
8328         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8329 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8330       endif
8331 C Cartesian derivatives.
8332       if (lprn) then
8333         write (2,*) 'In eello6_graph2'
8334         do iii=1,2
8335           write (2,*) 'iii=',iii
8336           do kkk=1,5
8337             write (2,*) 'kkk=',kkk
8338             do jjj=1,2
8339               write (2,'(3(2f10.5),5x)')
8340      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8341             enddo
8342           enddo
8343         enddo
8344       endif
8345       do iii=1,2
8346         do kkk=1,5
8347           do lll=1,3
8348 #ifdef MOMENT
8349             if (iii.eq.1) then
8350               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8351             else
8352               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8353             endif
8354 #endif
8355             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8356      &        auxvec(1))
8357             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8358             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8359      &        auxvec(1))
8360             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8361             call transpose2(EUg(1,1,k),auxmat(1,1))
8362             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8363      &        pizda(1,1))
8364             vv(1)=pizda(1,1)-pizda(2,2)
8365             vv(2)=pizda(1,2)+pizda(2,1)
8366             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8367 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8368 #ifdef MOMENT
8369             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8370 #else
8371             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8372 #endif
8373             if (swap) then
8374               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8375             else
8376               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8377             endif
8378           enddo
8379         enddo
8380       enddo
8381       return
8382       end
8383 c----------------------------------------------------------------------------
8384       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8385       implicit real*8 (a-h,o-z)
8386       include 'DIMENSIONS'
8387       include 'DIMENSIONS.ZSCOPT'
8388       include 'COMMON.IOUNITS'
8389       include 'COMMON.CHAIN'
8390       include 'COMMON.DERIV'
8391       include 'COMMON.INTERACT'
8392       include 'COMMON.CONTACTS'
8393       include 'COMMON.TORSION'
8394       include 'COMMON.VAR'
8395       include 'COMMON.GEO'
8396       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8397       logical swap
8398 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8399 C                                                                              C
8400 C      Parallel       Antiparallel                                             C
8401 C                                                                              C
8402 C          o             o                                                     C
8403 C         /l\   /   \   /j\                                                    C
8404 C        /   \ /     \ /   \                                                   C
8405 C       /| o |o       o| o |\                                                  C
8406 C       j|/k\|  /      |/k\|l /                                                C
8407 C        /   \ /       /   \ /                                                 C
8408 C       /     o       /     o                                                  C
8409 C       i             i                                                        C
8410 C                                                                              C
8411 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8412 C
8413 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8414 C           energy moment and not to the cluster cumulant.
8415       iti=itortyp(itype(i))
8416       if (j.lt.nres-1) then
8417         itj1=itortyp(itype(j+1))
8418       else
8419         itj1=ntortyp+1
8420       endif
8421       itk=itortyp(itype(k))
8422       itk1=itortyp(itype(k+1))
8423       if (l.lt.nres-1) then
8424         itl1=itortyp(itype(l+1))
8425       else
8426         itl1=ntortyp+1
8427       endif
8428 #ifdef MOMENT
8429       s1=dip(4,jj,i)*dip(4,kk,k)
8430 #endif
8431       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8432       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8433       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8434       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8435       call transpose2(EE(1,1,itk),auxmat(1,1))
8436       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8437       vv(1)=pizda(1,1)+pizda(2,2)
8438       vv(2)=pizda(2,1)-pizda(1,2)
8439       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8440 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8441 #ifdef MOMENT
8442       eello6_graph3=-(s1+s2+s3+s4)
8443 #else
8444       eello6_graph3=-(s2+s3+s4)
8445 #endif
8446 c      eello6_graph3=-s4
8447       if (.not. calc_grad) return
8448 C Derivatives in gamma(k-1)
8449       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8450       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8451       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8452       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8453 C Derivatives in gamma(l-1)
8454       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8455       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8456       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8457       vv(1)=pizda(1,1)+pizda(2,2)
8458       vv(2)=pizda(2,1)-pizda(1,2)
8459       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8460       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8461 C Cartesian derivatives.
8462       do iii=1,2
8463         do kkk=1,5
8464           do lll=1,3
8465 #ifdef MOMENT
8466             if (iii.eq.1) then
8467               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8468             else
8469               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8470             endif
8471 #endif
8472             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8473      &        auxvec(1))
8474             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8475             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8476      &        auxvec(1))
8477             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8478             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8479      &        pizda(1,1))
8480             vv(1)=pizda(1,1)+pizda(2,2)
8481             vv(2)=pizda(2,1)-pizda(1,2)
8482             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8483 #ifdef MOMENT
8484             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8485 #else
8486             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8487 #endif
8488             if (swap) then
8489               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8490             else
8491               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8492             endif
8493 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8494           enddo
8495         enddo
8496       enddo
8497       return
8498       end
8499 c----------------------------------------------------------------------------
8500       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8501       implicit real*8 (a-h,o-z)
8502       include 'DIMENSIONS'
8503       include 'DIMENSIONS.ZSCOPT'
8504       include 'COMMON.IOUNITS'
8505       include 'COMMON.CHAIN'
8506       include 'COMMON.DERIV'
8507       include 'COMMON.INTERACT'
8508       include 'COMMON.CONTACTS'
8509       include 'COMMON.TORSION'
8510       include 'COMMON.VAR'
8511       include 'COMMON.GEO'
8512       include 'COMMON.FFIELD'
8513       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8514      & auxvec1(2),auxmat1(2,2)
8515       logical swap
8516 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8517 C                                                                              C
8518 C      Parallel       Antiparallel                                             C
8519 C                                                                              C
8520 C          o             o                                                     C
8521 C         /l\   /   \   /j\                                                    C
8522 C        /   \ /     \ /   \                                                   C
8523 C       /| o |o       o| o |\                                                  C
8524 C     \ j|/k\|      \  |/k\|l                                                  C
8525 C      \ /   \       \ /   \                                                   C
8526 C       o     \       o     \                                                  C
8527 C       i             i                                                        C
8528 C                                                                              C
8529 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8530 C
8531 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8532 C           energy moment and not to the cluster cumulant.
8533 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8534       iti=itortyp(itype(i))
8535       itj=itortyp(itype(j))
8536       if (j.lt.nres-1) then
8537         itj1=itortyp(itype(j+1))
8538       else
8539         itj1=ntortyp+1
8540       endif
8541       itk=itortyp(itype(k))
8542       if (k.lt.nres-1) then
8543         itk1=itortyp(itype(k+1))
8544       else
8545         itk1=ntortyp+1
8546       endif
8547       itl=itortyp(itype(l))
8548       if (l.lt.nres-1) then
8549         itl1=itortyp(itype(l+1))
8550       else
8551         itl1=ntortyp+1
8552       endif
8553 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8554 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8555 cd     & ' itl',itl,' itl1',itl1
8556 #ifdef MOMENT
8557       if (imat.eq.1) then
8558         s1=dip(3,jj,i)*dip(3,kk,k)
8559       else
8560         s1=dip(2,jj,j)*dip(2,kk,l)
8561       endif
8562 #endif
8563       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8564       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8565       if (j.eq.l+1) then
8566         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8567         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8568       else
8569         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8570         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8571       endif
8572       call transpose2(EUg(1,1,k),auxmat(1,1))
8573       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8574       vv(1)=pizda(1,1)-pizda(2,2)
8575       vv(2)=pizda(2,1)+pizda(1,2)
8576       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8577 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8578 #ifdef MOMENT
8579       eello6_graph4=-(s1+s2+s3+s4)
8580 #else
8581       eello6_graph4=-(s2+s3+s4)
8582 #endif
8583       if (.not. calc_grad) return
8584 C Derivatives in gamma(i-1)
8585       if (i.gt.1) then
8586 #ifdef MOMENT
8587         if (imat.eq.1) then
8588           s1=dipderg(2,jj,i)*dip(3,kk,k)
8589         else
8590           s1=dipderg(4,jj,j)*dip(2,kk,l)
8591         endif
8592 #endif
8593         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8594         if (j.eq.l+1) then
8595           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8596           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8597         else
8598           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8599           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8600         endif
8601         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8602         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8603 cd          write (2,*) 'turn6 derivatives'
8604 #ifdef MOMENT
8605           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8606 #else
8607           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8608 #endif
8609         else
8610 #ifdef MOMENT
8611           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8612 #else
8613           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8614 #endif
8615         endif
8616       endif
8617 C Derivatives in gamma(k-1)
8618 #ifdef MOMENT
8619       if (imat.eq.1) then
8620         s1=dip(3,jj,i)*dipderg(2,kk,k)
8621       else
8622         s1=dip(2,jj,j)*dipderg(4,kk,l)
8623       endif
8624 #endif
8625       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8626       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8627       if (j.eq.l+1) then
8628         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8629         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8630       else
8631         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8632         s3=-0.5d0*scalar2(b1(1,tl),auxvec1(1))
8633       endif
8634       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8635       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8636       vv(1)=pizda(1,1)-pizda(2,2)
8637       vv(2)=pizda(2,1)+pizda(1,2)
8638       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8639       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8640 #ifdef MOMENT
8641         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8642 #else
8643         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8644 #endif
8645       else
8646 #ifdef MOMENT
8647         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8648 #else
8649         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8650 #endif
8651       endif
8652 C Derivatives in gamma(j-1) or gamma(l-1)
8653       if (l.eq.j+1 .and. l.gt.1) then
8654         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8655         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8656         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8657         vv(1)=pizda(1,1)-pizda(2,2)
8658         vv(2)=pizda(2,1)+pizda(1,2)
8659         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8660         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8661       else if (j.gt.1) then
8662         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8663         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8664         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8665         vv(1)=pizda(1,1)-pizda(2,2)
8666         vv(2)=pizda(2,1)+pizda(1,2)
8667         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8668         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8669           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8670         else
8671           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8672         endif
8673       endif
8674 C Cartesian derivatives.
8675       do iii=1,2
8676         do kkk=1,5
8677           do lll=1,3
8678 #ifdef MOMENT
8679             if (iii.eq.1) then
8680               if (imat.eq.1) then
8681                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8682               else
8683                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8684               endif
8685             else
8686               if (imat.eq.1) then
8687                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8688               else
8689                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8690               endif
8691             endif
8692 #endif
8693             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8694      &        auxvec(1))
8695             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8696             if (j.eq.l+1) then
8697               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8698      &          b1(1,j+1),auxvec(1))
8699               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8700             else
8701               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8702      &          b1(1,l+1),auxvec(1))
8703               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8704             endif
8705             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8706      &        pizda(1,1))
8707             vv(1)=pizda(1,1)-pizda(2,2)
8708             vv(2)=pizda(2,1)+pizda(1,2)
8709             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8710             if (swap) then
8711               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8712 #ifdef MOMENT
8713                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8714      &             -(s1+s2+s4)
8715 #else
8716                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8717      &             -(s2+s4)
8718 #endif
8719                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8720               else
8721 #ifdef MOMENT
8722                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8723 #else
8724                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8725 #endif
8726                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8727               endif
8728             else
8729 #ifdef MOMENT
8730               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8731 #else
8732               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8733 #endif
8734               if (l.eq.j+1) then
8735                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8736               else
8737                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8738               endif
8739             endif
8740           enddo
8741         enddo
8742       enddo
8743       return
8744       end
8745 c----------------------------------------------------------------------------
8746       double precision function eello_turn6(i,jj,kk)
8747       implicit real*8 (a-h,o-z)
8748       include 'DIMENSIONS'
8749       include 'DIMENSIONS.ZSCOPT'
8750       include 'COMMON.IOUNITS'
8751       include 'COMMON.CHAIN'
8752       include 'COMMON.DERIV'
8753       include 'COMMON.INTERACT'
8754       include 'COMMON.CONTACTS'
8755       include 'COMMON.TORSION'
8756       include 'COMMON.VAR'
8757       include 'COMMON.GEO'
8758       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8759      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8760      &  ggg1(3),ggg2(3)
8761       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8762      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8763 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8764 C           the respective energy moment and not to the cluster cumulant.
8765       eello_turn6=0.0d0
8766       j=i+4
8767       k=i+1
8768       l=i+3
8769       iti=itortyp(itype(i))
8770       itk=itortyp(itype(k))
8771       itk1=itortyp(itype(k+1))
8772       itl=itortyp(itype(l))
8773       itj=itortyp(itype(j))
8774 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8775 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8776 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8777 cd        eello6=0.0d0
8778 cd        return
8779 cd      endif
8780 cd      write (iout,*)
8781 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8782 cd     &   ' and',k,l
8783 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8784       do iii=1,2
8785         do kkk=1,5
8786           do lll=1,3
8787             derx_turn(lll,kkk,iii)=0.0d0
8788           enddo
8789         enddo
8790       enddo
8791 cd      eij=1.0d0
8792 cd      ekl=1.0d0
8793 cd      ekont=1.0d0
8794       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8795 cd      eello6_5=0.0d0
8796 cd      write (2,*) 'eello6_5',eello6_5
8797 #ifdef MOMENT
8798       call transpose2(AEA(1,1,1),auxmat(1,1))
8799       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8800       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8801       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8802 #else
8803       s1 = 0.0d0
8804 #endif
8805       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8806       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8807       s2 = scalar2(b1(1,k),vtemp1(1))
8808 #ifdef MOMENT
8809       call transpose2(AEA(1,1,2),atemp(1,1))
8810       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8811       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8812       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8813 #else
8814       s8=0.0d0
8815 #endif
8816       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8817       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8818       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8819 #ifdef MOMENT
8820       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8821       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8822       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8823       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8824       ss13 = scalar2(b1(1,k),vtemp4(1))
8825       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8826 #else
8827       s13=0.0d0
8828 #endif
8829 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8830 c      s1=0.0d0
8831 c      s2=0.0d0
8832 c      s8=0.0d0
8833 c      s12=0.0d0
8834 c      s13=0.0d0
8835       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8836       if (calc_grad) then
8837 C Derivatives in gamma(i+2)
8838 #ifdef MOMENT
8839       call transpose2(AEA(1,1,1),auxmatd(1,1))
8840       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8841       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8842       call transpose2(AEAderg(1,1,2),atempd(1,1))
8843       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8844       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8845 #else
8846       s8d=0.0d0
8847 #endif
8848       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8849       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8850       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8851 c      s1d=0.0d0
8852 c      s2d=0.0d0
8853 c      s8d=0.0d0
8854 c      s12d=0.0d0
8855 c      s13d=0.0d0
8856       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8857 C Derivatives in gamma(i+3)
8858 #ifdef MOMENT
8859       call transpose2(AEA(1,1,1),auxmatd(1,1))
8860       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8861       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8862       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8863 #else
8864       s1d=0.0d0
8865 #endif
8866       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8867       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8868       s2d = scalar2(b1(1,k),vtemp1d(1))
8869 #ifdef MOMENT
8870       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8871       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8872 #endif
8873       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8874 #ifdef MOMENT
8875       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8876       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8877       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8878 #else
8879       s13d=0.0d0
8880 #endif
8881 c      s1d=0.0d0
8882 c      s2d=0.0d0
8883 c      s8d=0.0d0
8884 c      s12d=0.0d0
8885 c      s13d=0.0d0
8886 #ifdef MOMENT
8887       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8888      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8889 #else
8890       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8891      &               -0.5d0*ekont*(s2d+s12d)
8892 #endif
8893 C Derivatives in gamma(i+4)
8894       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8895       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8896       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8897 #ifdef MOMENT
8898       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8899       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8900       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8901 #else
8902       s13d = 0.0d0
8903 #endif
8904 c      s1d=0.0d0
8905 c      s2d=0.0d0
8906 c      s8d=0.0d0
8907 C      s12d=0.0d0
8908 c      s13d=0.0d0
8909 #ifdef MOMENT
8910       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8911 #else
8912       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8913 #endif
8914 C Derivatives in gamma(i+5)
8915 #ifdef MOMENT
8916       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8917       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8918       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8919 #else
8920       s1d = 0.0d0
8921 #endif
8922       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8923       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8924       s2d = scalar2(b1(1,k),vtemp1d(1))
8925 #ifdef MOMENT
8926       call transpose2(AEA(1,1,2),atempd(1,1))
8927       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8928       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8929 #else
8930       s8d = 0.0d0
8931 #endif
8932       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8933       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8934 #ifdef MOMENT
8935       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8936       ss13d = scalar2(b1(1,k),vtemp4d(1))
8937       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8938 #else
8939       s13d = 0.0d0
8940 #endif
8941 c      s1d=0.0d0
8942 c      s2d=0.0d0
8943 c      s8d=0.0d0
8944 c      s12d=0.0d0
8945 c      s13d=0.0d0
8946 #ifdef MOMENT
8947       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8948      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8949 #else
8950       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8951      &               -0.5d0*ekont*(s2d+s12d)
8952 #endif
8953 C Cartesian derivatives
8954       do iii=1,2
8955         do kkk=1,5
8956           do lll=1,3
8957 #ifdef MOMENT
8958             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8959             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8960             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8961 #else
8962             s1d = 0.0d0
8963 #endif
8964             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8965             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8966      &          vtemp1d(1))
8967             s2d = scalar2(b1(1,k),vtemp1d(1))
8968 #ifdef MOMENT
8969             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8970             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8971             s8d = -(atempd(1,1)+atempd(2,2))*
8972      &           scalar2(cc(1,1,itl),vtemp2(1))
8973 #else
8974             s8d = 0.0d0
8975 #endif
8976             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8977      &           auxmatd(1,1))
8978             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8979             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8980 c      s1d=0.0d0
8981 c      s2d=0.0d0
8982 c      s8d=0.0d0
8983 c      s12d=0.0d0
8984 c      s13d=0.0d0
8985 #ifdef MOMENT
8986             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8987      &        - 0.5d0*(s1d+s2d)
8988 #else
8989             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8990      &        - 0.5d0*s2d
8991 #endif
8992 #ifdef MOMENT
8993             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8994      &        - 0.5d0*(s8d+s12d)
8995 #else
8996             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8997      &        - 0.5d0*s12d
8998 #endif
8999           enddo
9000         enddo
9001       enddo
9002 #ifdef MOMENT
9003       do kkk=1,5
9004         do lll=1,3
9005           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9006      &      achuj_tempd(1,1))
9007           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9008           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9009           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9010           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9011           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9012      &      vtemp4d(1))
9013           ss13d = scalar2(b1(1,k),vtemp4d(1))
9014           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9015           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9016         enddo
9017       enddo
9018 #endif
9019 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9020 cd     &  16*eel_turn6_num
9021 cd      goto 1112
9022       if (j.lt.nres-1) then
9023         j1=j+1
9024         j2=j-1
9025       else
9026         j1=j-1
9027         j2=j-2
9028       endif
9029       if (l.lt.nres-1) then
9030         l1=l+1
9031         l2=l-1
9032       else
9033         l1=l-1
9034         l2=l-2
9035       endif
9036       do ll=1,3
9037         ggg1(ll)=eel_turn6*g_contij(ll,1)
9038         ggg2(ll)=eel_turn6*g_contij(ll,2)
9039         ghalf=0.5d0*ggg1(ll)
9040 cd        ghalf=0.0d0
9041         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
9042      &    +ekont*derx_turn(ll,2,1)
9043         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9044         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
9045      &    +ekont*derx_turn(ll,4,1)
9046         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9047         ghalf=0.5d0*ggg2(ll)
9048 cd        ghalf=0.0d0
9049         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
9050      &    +ekont*derx_turn(ll,2,2)
9051         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9052         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
9053      &    +ekont*derx_turn(ll,4,2)
9054         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9055       enddo
9056 cd      goto 1112
9057       do m=i+1,j-1
9058         do ll=1,3
9059           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9060         enddo
9061       enddo
9062       do m=k+1,l-1
9063         do ll=1,3
9064           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9065         enddo
9066       enddo
9067 1112  continue
9068       do m=i+2,j2
9069         do ll=1,3
9070           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9071         enddo
9072       enddo
9073       do m=k+2,l2
9074         do ll=1,3
9075           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9076         enddo
9077       enddo
9078 cd      do iii=1,nres-3
9079 cd        write (2,*) iii,g_corr6_loc(iii)
9080 cd      enddo
9081       endif
9082       eello_turn6=ekont*eel_turn6
9083 cd      write (2,*) 'ekont',ekont
9084 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9085       return
9086       end
9087 crc-------------------------------------------------
9088       SUBROUTINE MATVEC2(A1,V1,V2)
9089       implicit real*8 (a-h,o-z)
9090       include 'DIMENSIONS'
9091       DIMENSION A1(2,2),V1(2),V2(2)
9092 c      DO 1 I=1,2
9093 c        VI=0.0
9094 c        DO 3 K=1,2
9095 c    3     VI=VI+A1(I,K)*V1(K)
9096 c        Vaux(I)=VI
9097 c    1 CONTINUE
9098
9099       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9100       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9101
9102       v2(1)=vaux1
9103       v2(2)=vaux2
9104       END
9105 C---------------------------------------
9106       SUBROUTINE MATMAT2(A1,A2,A3)
9107       implicit real*8 (a-h,o-z)
9108       include 'DIMENSIONS'
9109       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9110 c      DIMENSION AI3(2,2)
9111 c        DO  J=1,2
9112 c          A3IJ=0.0
9113 c          DO K=1,2
9114 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9115 c          enddo
9116 c          A3(I,J)=A3IJ
9117 c       enddo
9118 c      enddo
9119
9120       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9121       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9122       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9123       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9124
9125       A3(1,1)=AI3_11
9126       A3(2,1)=AI3_21
9127       A3(1,2)=AI3_12
9128       A3(2,2)=AI3_22
9129       END
9130
9131 c-------------------------------------------------------------------------
9132       double precision function scalar2(u,v)
9133       implicit none
9134       double precision u(2),v(2)
9135       double precision sc
9136       integer i
9137       scalar2=u(1)*v(1)+u(2)*v(2)
9138       return
9139       end
9140
9141 C-----------------------------------------------------------------------------
9142
9143       subroutine transpose2(a,at)
9144       implicit none
9145       double precision a(2,2),at(2,2)
9146       at(1,1)=a(1,1)
9147       at(1,2)=a(2,1)
9148       at(2,1)=a(1,2)
9149       at(2,2)=a(2,2)
9150       return
9151       end
9152 c--------------------------------------------------------------------------
9153       subroutine transpose(n,a,at)
9154       implicit none
9155       integer n,i,j
9156       double precision a(n,n),at(n,n)
9157       do i=1,n
9158         do j=1,n
9159           at(j,i)=a(i,j)
9160         enddo
9161       enddo
9162       return
9163       end
9164 C---------------------------------------------------------------------------
9165       subroutine prodmat3(a1,a2,kk,transp,prod)
9166       implicit none
9167       integer i,j
9168       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9169       logical transp
9170 crc      double precision auxmat(2,2),prod_(2,2)
9171
9172       if (transp) then
9173 crc        call transpose2(kk(1,1),auxmat(1,1))
9174 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9175 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9176
9177            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9178      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9179            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9180      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9181            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9182      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9183            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9184      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9185
9186       else
9187 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9188 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9189
9190            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9191      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9192            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9193      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9194            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9195      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9196            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9197      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9198
9199       endif
9200 c      call transpose2(a2(1,1),a2t(1,1))
9201
9202 crc      print *,transp
9203 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9204 crc      print *,((prod(i,j),i=1,2),j=1,2)
9205
9206       return
9207       end
9208 C-----------------------------------------------------------------------------
9209       double precision function scalar(u,v)
9210       implicit none
9211       double precision u(3),v(3)
9212       double precision sc
9213       integer i
9214       sc=0.0d0
9215       do i=1,3
9216         sc=sc+u(i)*v(i)
9217       enddo
9218       scalar=sc
9219       return
9220       end
9221