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

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'sizesclu.dat'
   5
   6       external proc_proc
   7 #ifdef WINPGI
   8 cMS$ATTRIBUTES C ::  proc_proc
   9 #endif
  10
  11       include 'COMMON.IOUNITS'
  12       double precision energia(0:max_ene),energia1(0:max_ene+1)
  13 #ifdef MPL
  14       include 'COMMON.INFO'
  15       external d_vadd
  16       integer ready
  17 #endif
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       double precision fact(5)
  24 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  25 cd    print *,'nnt=',nnt,' nct=',nct
  26 C
  27 C Compute the side-chain and electrostatic interaction energy
  28 C
  29       goto (101,102,103,104,105,106) ipot
  30 C Lennard-Jones potential.
  31   101 call elj(evdw)
  32 cd    print '(a)','Exit ELJ'
  33       goto 107
  34 C Lennard-Jones-Kihara potential (shifted).
  35   102 call eljk(evdw)
  36       goto 107
  37 C Berne-Pechukas potential (dilated LJ, angular dependence).
  38   103 call ebp(evdw)
  39       goto 107
  40 C Gay-Berne potential (shifted LJ, angular dependence).
  41   104 call egb(evdw)
  42       goto 107
  43 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  44   105 call egbv(evdw)
  45       goto 107
  46 C New SC-SC potential
  47   106 call emomo(evdw,evdw_p,evdw_m)
  48 C
  49 C Calculate electrostatic (H-bonding) energy of the main chain.
  50 C
  51   107 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  52 C
  53 C Calculate excluded-volume interaction energy between peptide groups
  54 C and side chains.
  55 C
  56       call escp(evdw2,evdw2_14)
  57 c
  58 c Calculate the bond-stretching energy
  59 c
  60       call ebond(estr)
  61 c      write (iout,*) "estr",estr
  62 C
  63 C Calculate the disulfide-bridge and other energy and the contributions
  64 C from other distance constraints.
  65 cd    print *,'Calling EHPB'
  66       call edis(ehpb)
  67 cd    print *,'EHPB exitted succesfully.'
  68 C
  69 C Calculate the virtual-bond-angle energy.
  70 C
  71       call ebend(ebe)
  72 cd    print *,'Bend energy finished.'
  73 C
  74 C Calculate the SC local energy.
  75 C
  76       call esc(escloc)
  77 cd    print *,'SCLOC energy finished.'
  78 C
  79 C Calculate the virtual-bond torsional energy.
  80 C
  81 cd    print *,'nterm=',nterm
  82       call etor(etors,edihcnstr,fact(1))
  83 C
  84 C 6/23/01 Calculate double-torsional energy
  85 C
  86       call etor_d(etors_d,fact(2))
  87 C
  88 C 21/5/07 Calculate local sicdechain correlation energy
  89 C
  90       call eback_sc_corr(esccor,fact(1))
  91 C
  92 C 12/1/95 Multi-body terms
  93 C
  94       n_corr=0
  95       n_corr1=0
  96       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  97      &    .or. wturn6.gt.0.0d0) then
  98 c         print *,"calling multibody_eello"
  99          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 100 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 101 c         print *,ecorr,ecorr5,ecorr6,eturn6
 102       endif
 103       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 104          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 105       endif
 106 C     call multibody(ecorr)
 107 C
 108 C Sum the energies
 109 C
 110 #ifdef SPLITELE
 111       etot=wsc*evdw+wscp*evdw2+welec*fact(1)*ees+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+wscp*evdw2+welec*fact(1)*(ees+evdw1)
 120      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 121      & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 122      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 123      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 124      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 125      & +wbond*estr+wsccor*fact(1)*esccor
 126 #endif
 127       energia(0)=etot
 128       energia(1)=evdw
 129 #ifdef SCP14
 130       energia(2)=evdw2-evdw2_14
 131       energia(17)=evdw2_14
 132 #else
 133       energia(2)=evdw2
 134       energia(17)=0.0d0
 135 #endif
 136 #ifdef SPLITELE
 137       energia(3)=ees
 138       energia(16)=evdw1
 139 #else
 140       energia(3)=ees+evdw1
 141       energia(16)=0.0d0
 142 #endif
 143       energia(4)=ecorr
 144       energia(5)=ecorr5
 145       energia(6)=ecorr6
 146       energia(7)=eel_loc
 147       energia(8)=eello_turn3
 148       energia(9)=eello_turn4
 149       energia(10)=eturn6
 150       energia(11)=ebe
 151       energia(12)=escloc
 152       energia(13)=etors
 153       energia(14)=etors_d
 154       energia(15)=ehpb
 155       energia(18)=estr
 156       energia(19)=esccor
 157       energia(20)=edihcnstr
 158 c detecting NaNQ
 159       i=0
 160 #ifdef WINPGI
 161       idumm=proc_proc(etot,i)
 162 #else
 163       call proc_proc(etot,i)
 164 #endif
 165       if(i.eq.1)energia(0)=1.0d+99
 166 #ifdef MPL
 167 c     endif
 168 #endif
 169       if (calc_grad) then
 170 C
 171 C Sum up the components of the Cartesian gradient.
 172 C
 173 #ifdef SPLITELE
 174       do i=1,nct
 175         do j=1,3
 176           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 177      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 178      &                wbond*gradb(j,i)+
 179      &                wstrain*ghpbc(j,i)+
 180      &                wcorr*fact(3)*gradcorr(j,i)+
 181      &                wel_loc*fact(2)*gel_loc(j,i)+
 182      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 183      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 184      &                wcorr5*fact(4)*gradcorr5(j,i)+
 185      &                wcorr6*fact(5)*gradcorr6(j,i)+
 186      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 187      &                wsccor*fact(2)*gsccorc(j,i)
 188           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 189      &                  wbond*gradbx(j,i)+
 190      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)
 191         enddo
 192 #else
 193       do i=1,nct
 194         do j=1,3
 195           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 196      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 197      &                wbond*gradb(j,i)+
 198      &                wcorr*fact(3)*gradcorr(j,i)+
 199      &                wel_loc*fact(2)*gel_loc(j,i)+
 200      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 201      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 202      &                wcorr5*fact(4)*gradcorr5(j,i)+
 203      &                wcorr6*fact(5)*gradcorr6(j,i)+
 204      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 205      &                wsccor*fact(2)*gsccorc(j,i)
 206           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 207      &                  wbond*gradbx(j,i)+
 208      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)
 209         enddo
 210 #endif
 211 cd      print '(i3,9(1pe12.4))',i,(gvdwc(k,i),k=1,3),(gelc(k,i),k=1,3),
 212 cd   &        (gradc(k,i),k=1,3)
 213       enddo
 214
 215
 216       do i=1,nres-3
 217 cd        write (iout,*) i,g_corr5_loc(i)
 218         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 219      &   +wcorr5*fact(4)*g_corr5_loc(i)
 220      &   +wcorr6*fact(5)*g_corr6_loc(i)
 221      &   +wturn4*fact(3)*gel_loc_turn4(i)
 222      &   +wturn3*fact(2)*gel_loc_turn3(i)
 223      &   +wturn6*fact(5)*gel_loc_turn6(i)
 224      &   +wel_loc*fact(2)*gel_loc_loc(i)+
 225      &   +wsccor*fact(1)*gsccor_loc(i)
 226       enddo
 227       endif
 228 cd    call enerprint(energia(0),fact)
 229 cd    call intout
 230 cd    stop
 231       return
 232       end
 233 C------------------------------------------------------------------------
 234       subroutine enerprint(energia,fact)
 235       implicit real*8 (a-h,o-z)
 236       include 'DIMENSIONS'
 237       include 'sizesclu.dat'
 238       include 'COMMON.IOUNITS'
 239       include 'COMMON.FFIELD'
 240       include 'COMMON.SBRIDGE'
 241       double precision energia(0:max_ene),fact(5)
 242       etot=energia(0)
 243       evdw=energia(1)
 244 #ifdef SCP14
 245       evdw2=energia(2)+energia(17)
 246 #else
 247       evdw2=energia(2)
 248 #endif
 249       ees=energia(3)
 250 #ifdef SPLITELE
 251       evdw1=energia(16)
 252 #endif
 253       ecorr=energia(4)
 254       ecorr5=energia(5)
 255       ecorr6=energia(6)
 256       eel_loc=energia(7)
 257       eello_turn3=energia(8)
 258       eello_turn4=energia(9)
 259       eello_turn6=energia(10)
 260       ebe=energia(11)
 261       escloc=energia(12)
 262       etors=energia(13)
 263       etors_d=energia(14)
 264       ehpb=energia(15)
 265       esccor=energia(19)
 266       edihcnstr=energia(20)
 267       estr=energia(18)
 268 #ifdef SPLITELE
 269       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 270      &  wvdwpp,
 271      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 272      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 273      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 274      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 275      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 276      &  esccor,wsccor*fact(1),edihcnstr,ebr*nss,etot
 277    10 format (/'Virtual-chain energies:'//
 278      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 279      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 280      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 281      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 282      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 283      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 284      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 285      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 286      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 287      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 288      & ' (SS bridges & dist. cnstr.)'/
 289      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 290      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 291      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 292      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 293      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 294      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 295      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 296      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 297      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 298      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 299      & 'ETOT=  ',1pE16.6,' (total)')
 300 #else
 301       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 302      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 303      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 304      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 305      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 306      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 307      &  edihcnstr,ebr*nss,etot
 308    10 format (/'Virtual-chain energies:'//
 309      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 310      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 311      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 312      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 313      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 314      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 315      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 316      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 317      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 318      & ' (SS bridges & dist. cnstr.)'/
 319      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 320      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 321      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 322      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 323      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 324      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 325      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 326      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 327      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 328      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 329      & 'ETOT=  ',1pE16.6,' (total)')
 330 #endif
 331       return
 332       end
 333 C-----------------------------------------------------------------------
 334       subroutine elj(evdw)
 335 C
 336 C This subroutine calculates the interaction energy of nonbonded side chains
 337 C assuming the LJ potential of interaction.
 338 C
 339       implicit real*8 (a-h,o-z)
 340       include 'DIMENSIONS'
 341       include 'sizesclu.dat'
 342 c      include "DIMENSIONS.COMPAR"
 343       parameter (accur=1.0d-10)
 344       include 'COMMON.GEO'
 345       include 'COMMON.VAR'
 346       include 'COMMON.LOCAL'
 347       include 'COMMON.CHAIN'
 348       include 'COMMON.DERIV'
 349       include 'COMMON.INTERACT'
 350       include 'COMMON.TORSION'
 351       include 'COMMON.SBRIDGE'
 352       include 'COMMON.NAMES'
 353       include 'COMMON.IOUNITS'
 354       include 'COMMON.CONTACTS'
 355       dimension gg(3)
 356       integer icant
 357       external icant
 358 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 359       evdw=0.0D0
 360       do i=iatsc_s,iatsc_e
 361         itypi=itype(i)
 362         itypi1=itype(i+1)
 363         xi=c(1,nres+i)
 364         yi=c(2,nres+i)
 365         zi=c(3,nres+i)
 366 C Change 12/1/95
 367         num_conti=0
 368 C
 369 C Calculate SC interaction energy.
 370 C
 371         do iint=1,nint_gr(i)
 372 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 373 cd   &                  'iend=',iend(i,iint)
 374           do j=istart(i,iint),iend(i,iint)
 375             itypj=itype(j)
 376             xj=c(1,nres+j)-xi
 377             yj=c(2,nres+j)-yi
 378             zj=c(3,nres+j)-zi
 379 C Change 12/1/95 to calculate four-body interactions
 380             rij=xj*xj+yj*yj+zj*zj
 381             rrij=1.0D0/rij
 382 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 383             eps0ij=eps(itypi,itypj)
 384             fac=rrij**expon2
 385             e1=fac*fac*aa(itypi,itypj)
 386             e2=fac*bb(itypi,itypj)
 387             evdwij=e1+e2
 388             ij=icant(itypi,itypj)
 389 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 390 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 391 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 392 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 393 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 394 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 395             evdw=evdw+evdwij
 396             if (calc_grad) then
 397 C
 398 C Calculate the components of the gradient in DC and X
 399 C
 400             fac=-rrij*(e1+evdwij)
 401             gg(1)=xj*fac
 402             gg(2)=yj*fac
 403             gg(3)=zj*fac
 404             do k=1,3
 405               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 406               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 407             enddo
 408             do k=i,j-1
 409               do l=1,3
 410                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 411               enddo
 412             enddo
 413             endif
 414 C
 415 C 12/1/95, revised on 5/20/97
 416 C
 417 C Calculate the contact function. The ith column of the array JCONT will
 418 C contain the numbers of atoms that make contacts with the atom I (of numbers
 419 C greater than I). The arrays FACONT and GACONT will contain the values of
 420 C the contact function and its derivative.
 421 C
 422 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 423 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 424 C Uncomment next line, if the correlation interactions are contact function only
 425             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 426               rij=dsqrt(rij)
 427               sigij=sigma(itypi,itypj)
 428               r0ij=rs0(itypi,itypj)
 429 C
 430 C Check whether the SC's are not too far to make a contact.
 431 C
 432               rcut=1.5d0*r0ij
 433               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 434 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 435 C
 436               if (fcont.gt.0.0D0) then
 437 C If the SC-SC distance if close to sigma, apply spline.
 438 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 439 cAdam &             fcont1,fprimcont1)
 440 cAdam           fcont1=1.0d0-fcont1
 441 cAdam           if (fcont1.gt.0.0d0) then
 442 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 443 cAdam             fcont=fcont*fcont1
 444 cAdam           endif
 445 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 446 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 447 cga             do k=1,3
 448 cga               gg(k)=gg(k)*eps0ij
 449 cga             enddo
 450 cga             eps0ij=-evdwij*eps0ij
 451 C Uncomment for AL's type of SC correlation interactions.
 452 cadam           eps0ij=-evdwij
 453                 num_conti=num_conti+1
 454                 jcont(num_conti,i)=j
 455                 facont(num_conti,i)=fcont*eps0ij
 456                 fprimcont=eps0ij*fprimcont/rij
 457                 fcont=expon*fcont
 458 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 459 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 460 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 461 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 462                 gacont(1,num_conti,i)=-fprimcont*xj
 463                 gacont(2,num_conti,i)=-fprimcont*yj
 464                 gacont(3,num_conti,i)=-fprimcont*zj
 465 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 466 cd              write (iout,'(2i3,3f10.5)')
 467 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 468               endif
 469             endif
 470           enddo      ! j
 471         enddo        ! iint
 472 C Change 12/1/95
 473         num_cont(i)=num_conti
 474       enddo          ! i
 475       if (calc_grad) then
 476       do i=1,nct
 477         do j=1,3
 478           gvdwc(j,i)=expon*gvdwc(j,i)
 479           gvdwx(j,i)=expon*gvdwx(j,i)
 480         enddo
 481       enddo
 482       endif
 483 C******************************************************************************
 484 C
 485 C                              N O T E !!!
 486 C
 487 C To save time, the factor of EXPON has been extracted from ALL components
 488 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 489 C use!
 490 C
 491 C******************************************************************************
 492       return
 493       end
 494 C-----------------------------------------------------------------------------
 495       subroutine eljk(evdw)
 496 C
 497 C This subroutine calculates the interaction energy of nonbonded side chains
 498 C assuming the LJK potential of interaction.
 499 C
 500       implicit real*8 (a-h,o-z)
 501       include 'DIMENSIONS'
 502       include 'sizesclu.dat'
 503 c      include "DIMENSIONS.COMPAR"
 504       include 'COMMON.GEO'
 505       include 'COMMON.VAR'
 506       include 'COMMON.LOCAL'
 507       include 'COMMON.CHAIN'
 508       include 'COMMON.DERIV'
 509       include 'COMMON.INTERACT'
 510       include 'COMMON.IOUNITS'
 511       include 'COMMON.NAMES'
 512       dimension gg(3)
 513       logical scheck
 514       integer icant
 515       external icant
 516 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 517       evdw=0.0D0
 518       do i=iatsc_s,iatsc_e
 519         itypi=itype(i)
 520         itypi1=itype(i+1)
 521         xi=c(1,nres+i)
 522         yi=c(2,nres+i)
 523         zi=c(3,nres+i)
 524 C
 525 C Calculate SC interaction energy.
 526 C
 527         do iint=1,nint_gr(i)
 528           do j=istart(i,iint),iend(i,iint)
 529             itypj=itype(j)
 530             xj=c(1,nres+j)-xi
 531             yj=c(2,nres+j)-yi
 532             zj=c(3,nres+j)-zi
 533             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 534             fac_augm=rrij**expon
 535             e_augm=augm(itypi,itypj)*fac_augm
 536             r_inv_ij=dsqrt(rrij)
 537             rij=1.0D0/r_inv_ij
 538             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 539             fac=r_shift_inv**expon
 540             e1=fac*fac*aa(itypi,itypj)
 541             e2=fac*bb(itypi,itypj)
 542             evdwij=e_augm+e1+e2
 543             ij=icant(itypi,itypj)
 544 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 545 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 546 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 547 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 548 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 549 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 550 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 551             evdw=evdw+evdwij
 552             if (calc_grad) then
 553 C
 554 C Calculate the components of the gradient in DC and X
 555 C
 556             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 557             gg(1)=xj*fac
 558             gg(2)=yj*fac
 559             gg(3)=zj*fac
 560             do k=1,3
 561               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 562               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 563             enddo
 564             do k=i,j-1
 565               do l=1,3
 566                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 567               enddo
 568             enddo
 569             endif
 570           enddo      ! j
 571         enddo        ! iint
 572       enddo          ! i
 573       if (calc_grad) then
 574       do i=1,nct
 575         do j=1,3
 576           gvdwc(j,i)=expon*gvdwc(j,i)
 577           gvdwx(j,i)=expon*gvdwx(j,i)
 578         enddo
 579       enddo
 580       endif
 581       return
 582       end
 583 C-----------------------------------------------------------------------------
 584       subroutine ebp(evdw)
 585 C
 586 C This subroutine calculates the interaction energy of nonbonded side chains
 587 C assuming the Berne-Pechukas potential of interaction.
 588 C
 589       implicit real*8 (a-h,o-z)
 590       include 'DIMENSIONS'
 591       include 'sizesclu.dat'
 592 c      include "DIMENSIONS.COMPAR"
 593       include 'COMMON.GEO'
 594       include 'COMMON.VAR'
 595       include 'COMMON.LOCAL'
 596       include 'COMMON.CHAIN'
 597       include 'COMMON.DERIV'
 598       include 'COMMON.NAMES'
 599       include 'COMMON.INTERACT'
 600       include 'COMMON.IOUNITS'
 601       include 'COMMON.CALC'
 602       common /srutu/ icall
 603 c     double precision rrsave(maxdim)
 604       logical lprn
 605       integer icant
 606       external icant
 607       evdw=0.0D0
 608 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 609       evdw=0.0D0
 610 c     if (icall.eq.0) then
 611 c       lprn=.true.
 612 c     else
 613         lprn=.false.
 614 c     endif
 615       ind=0
 616       do i=iatsc_s,iatsc_e
 617         itypi=itype(i)
 618         itypi1=itype(i+1)
 619         xi=c(1,nres+i)
 620         yi=c(2,nres+i)
 621         zi=c(3,nres+i)
 622         dxi=dc_norm(1,nres+i)
 623         dyi=dc_norm(2,nres+i)
 624         dzi=dc_norm(3,nres+i)
 625         dsci_inv=vbld_inv(i+nres)
 626 C
 627 C Calculate SC interaction energy.
 628 C
 629         do iint=1,nint_gr(i)
 630           do j=istart(i,iint),iend(i,iint)
 631             ind=ind+1
 632             itypj=itype(j)
 633             dscj_inv=vbld_inv(j+nres)
 634             chi1=chi(itypi,itypj)
 635             chi2=chi(itypj,itypi)
 636             chi12=chi1*chi2
 637             chip1=chip(itypi)
 638             chip2=chip(itypj)
 639             chip12=chip1*chip2
 640             alf1=alp(itypi)
 641             alf2=alp(itypj)
 642             alf12=0.5D0*(alf1+alf2)
 643 C For diagnostics only!!!
 644 c           chi1=0.0D0
 645 c           chi2=0.0D0
 646 c           chi12=0.0D0
 647 c           chip1=0.0D0
 648 c           chip2=0.0D0
 649 c           chip12=0.0D0
 650 c           alf1=0.0D0
 651 c           alf2=0.0D0
 652 c           alf12=0.0D0
 653             xj=c(1,nres+j)-xi
 654             yj=c(2,nres+j)-yi
 655             zj=c(3,nres+j)-zi
 656             dxj=dc_norm(1,nres+j)
 657             dyj=dc_norm(2,nres+j)
 658             dzj=dc_norm(3,nres+j)
 659             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 660 cd          if (icall.eq.0) then
 661 cd            rrsave(ind)=rrij
 662 cd          else
 663 cd            rrij=rrsave(ind)
 664 cd          endif
 665             rij=dsqrt(rrij)
 666 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 667             call sc_angular
 668 C Calculate whole angle-dependent part of epsilon and contributions
 669 C to its derivatives
 670             fac=(rrij*sigsq)**expon2
 671             e1=fac*fac*aa(itypi,itypj)
 672             e2=fac*bb(itypi,itypj)
 673             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 674             eps2der=evdwij*eps3rt
 675             eps3der=evdwij*eps2rt
 676             evdwij=evdwij*eps2rt*eps3rt
 677             ij=icant(itypi,itypj)
 678             aux=eps1*eps2rt**2*eps3rt**2
 679             evdw=evdw+evdwij
 680             if (calc_grad) then
 681             if (lprn) then
 682             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 683             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 684 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 685 cd     &        restyp(itypi),i,restyp(itypj),j,
 686 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 687 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 688 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 689 cd     &        evdwij
 690             endif
 691 C Calculate gradient components.
 692             e1=e1*eps1*eps2rt**2*eps3rt**2
 693             fac=-expon*(e1+evdwij)
 694             sigder=fac/sigsq
 695             fac=rrij*fac
 696 C Calculate radial part of the gradient
 697             gg(1)=xj*fac
 698             gg(2)=yj*fac
 699             gg(3)=zj*fac
 700 C Calculate the angular part of the gradient and sum add the contributions
 701 C to the appropriate components of the Cartesian gradient.
 702             call sc_grad
 703             endif
 704           enddo      ! j
 705         enddo        ! iint
 706       enddo          ! i
 707 c     stop
 708       return
 709       end
 710 C-----------------------------------------------------------------------------
 711       subroutine egb(evdw)
 712 C
 713 C This subroutine calculates the interaction energy of nonbonded side chains
 714 C assuming the Gay-Berne potential of interaction.
 715 C
 716       implicit real*8 (a-h,o-z)
 717       include 'DIMENSIONS'
 718       include 'sizesclu.dat'
 719 c      include "DIMENSIONS.COMPAR"
 720       include 'COMMON.GEO'
 721       include 'COMMON.VAR'
 722       include 'COMMON.LOCAL'
 723       include 'COMMON.CHAIN'
 724       include 'COMMON.DERIV'
 725       include 'COMMON.NAMES'
 726       include 'COMMON.INTERACT'
 727       include 'COMMON.IOUNITS'
 728       include 'COMMON.CALC'
 729       logical lprn
 730       common /srutu/icall
 731       integer icant
 732       external icant
 733       evdw=0.0D0
 734 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 735       evdw=0.0D0
 736       lprn=.false.
 737 c      if (icall.gt.0) lprn=.true.
 738       ind=0
 739       do i=iatsc_s,iatsc_e
 740         itypi=itype(i)
 741         itypi1=itype(i+1)
 742         xi=c(1,nres+i)
 743         yi=c(2,nres+i)
 744         zi=c(3,nres+i)
 745         dxi=dc_norm(1,nres+i)
 746         dyi=dc_norm(2,nres+i)
 747         dzi=dc_norm(3,nres+i)
 748         dsci_inv=vbld_inv(i+nres)
 749 C
 750 C Calculate SC interaction energy.
 751 C
 752         do iint=1,nint_gr(i)
 753           do j=istart(i,iint),iend(i,iint)
 754             ind=ind+1
 755             itypj=itype(j)
 756             dscj_inv=vbld_inv(j+nres)
 757             sig0ij=sigma(itypi,itypj)
 758             chi1=chi(itypi,itypj)
 759             chi2=chi(itypj,itypi)
 760             chi12=chi1*chi2
 761             chip1=chip(itypi)
 762             chip2=chip(itypj)
 763             chip12=chip1*chip2
 764             alf1=alp(itypi)
 765             alf2=alp(itypj)
 766             alf12=0.5D0*(alf1+alf2)
 767 C For diagnostics only!!!
 768 c           chi1=0.0D0
 769 c           chi2=0.0D0
 770 c           chi12=0.0D0
 771 c           chip1=0.0D0
 772 c           chip2=0.0D0
 773 c           chip12=0.0D0
 774 c           alf1=0.0D0
 775 c           alf2=0.0D0
 776 c           alf12=0.0D0
 777             xj=c(1,nres+j)-xi
 778             yj=c(2,nres+j)-yi
 779             zj=c(3,nres+j)-zi
 780             dxj=dc_norm(1,nres+j)
 781             dyj=dc_norm(2,nres+j)
 782             dzj=dc_norm(3,nres+j)
 783 c            write (iout,*) i,j,xj,yj,zj
 784             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 785             rij=dsqrt(rrij)
 786 C Calculate angle-dependent terms of energy and contributions to their
 787 C derivatives.
 788             call sc_angular
 789             sigsq=1.0D0/sigsq
 790             sig=sig0ij*dsqrt(sigsq)
 791             rij_shift=1.0D0/rij-sig+sig0ij
 792 C I hate to put IF's in the loops, but here don't have another choice!!!!
 793             if (rij_shift.le.0.0D0) then
 794               evdw=1.0D20
 795               return
 796             endif
 797             sigder=-sig*sigsq
 798 c---------------------------------------------------------------
 799             rij_shift=1.0D0/rij_shift
 800             fac=rij_shift**expon
 801             e1=fac*fac*aa(itypi,itypj)
 802             e2=fac*bb(itypi,itypj)
 803             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 804             eps2der=evdwij*eps3rt
 805             eps3der=evdwij*eps2rt
 806             evdwij=evdwij*eps2rt*eps3rt
 807             evdw=evdw+evdwij
 808             ij=icant(itypi,itypj)
 809             aux=eps1*eps2rt**2*eps3rt**2
 810 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 811 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 812 c     &         aux*e2/eps(itypi,itypj)
 813             if (lprn) then
 814             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 815             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 816             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 817      &        restyp(itypi),i,restyp(itypj),j,
 818      &        epsi,sigm,chi1,chi2,chip1,chip2,
 819      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 820      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 821      &        evdwij
 822             endif
 823             if (calc_grad) then
 824 C Calculate gradient components.
 825             e1=e1*eps1*eps2rt**2*eps3rt**2
 826             fac=-expon*(e1+evdwij)*rij_shift
 827             sigder=fac*sigder
 828             fac=rij*fac
 829 C Calculate the radial part of the gradient
 830             gg(1)=xj*fac
 831             gg(2)=yj*fac
 832             gg(3)=zj*fac
 833 C Calculate angular part of the gradient.
 834             call sc_grad
 835             endif
 836           enddo      ! j
 837         enddo        ! iint
 838       enddo          ! i
 839       return
 840       end
 841 C-----------------------------------------------------------------------------
 842       subroutine egbv(evdw)
 843 C
 844 C This subroutine calculates the interaction energy of nonbonded side chains
 845 C assuming the Gay-Berne-Vorobjev potential of interaction.
 846 C
 847       implicit real*8 (a-h,o-z)
 848       include 'DIMENSIONS'
 849       include 'sizesclu.dat'
 850 c      include "DIMENSIONS.COMPAR"
 851       include 'COMMON.GEO'
 852       include 'COMMON.VAR'
 853       include 'COMMON.LOCAL'
 854       include 'COMMON.CHAIN'
 855       include 'COMMON.DERIV'
 856       include 'COMMON.NAMES'
 857       include 'COMMON.INTERACT'
 858       include 'COMMON.IOUNITS'
 859       include 'COMMON.CALC'
 860       common /srutu/ icall
 861       logical lprn
 862       integer icant
 863       external icant
 864       evdw=0.0D0
 865 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 866       evdw=0.0D0
 867       lprn=.false.
 868 c      if (icall.gt.0) lprn=.true.
 869       ind=0
 870       do i=iatsc_s,iatsc_e
 871         itypi=itype(i)
 872         itypi1=itype(i+1)
 873         xi=c(1,nres+i)
 874         yi=c(2,nres+i)
 875         zi=c(3,nres+i)
 876         dxi=dc_norm(1,nres+i)
 877         dyi=dc_norm(2,nres+i)
 878         dzi=dc_norm(3,nres+i)
 879         dsci_inv=vbld_inv(i+nres)
 880 C
 881 C Calculate SC interaction energy.
 882 C
 883         do iint=1,nint_gr(i)
 884           do j=istart(i,iint),iend(i,iint)
 885             ind=ind+1
 886             itypj=itype(j)
 887             dscj_inv=vbld_inv(j+nres)
 888             sig0ij=sigma(itypi,itypj)
 889             r0ij=r0(itypi,itypj)
 890             chi1=chi(itypi,itypj)
 891             chi2=chi(itypj,itypi)
 892             chi12=chi1*chi2
 893             chip1=chip(itypi)
 894             chip2=chip(itypj)
 895             chip12=chip1*chip2
 896             alf1=alp(itypi)
 897             alf2=alp(itypj)
 898             alf12=0.5D0*(alf1+alf2)
 899 C For diagnostics only!!!
 900 c           chi1=0.0D0
 901 c           chi2=0.0D0
 902 c           chi12=0.0D0
 903 c           chip1=0.0D0
 904 c           chip2=0.0D0
 905 c           chip12=0.0D0
 906 c           alf1=0.0D0
 907 c           alf2=0.0D0
 908 c           alf12=0.0D0
 909             xj=c(1,nres+j)-xi
 910             yj=c(2,nres+j)-yi
 911             zj=c(3,nres+j)-zi
 912             dxj=dc_norm(1,nres+j)
 913             dyj=dc_norm(2,nres+j)
 914             dzj=dc_norm(3,nres+j)
 915             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 916             rij=dsqrt(rrij)
 917 C Calculate angle-dependent terms of energy and contributions to their
 918 C derivatives.
 919             call sc_angular
 920             sigsq=1.0D0/sigsq
 921             sig=sig0ij*dsqrt(sigsq)
 922             rij_shift=1.0D0/rij-sig+r0ij
 923 C I hate to put IF's in the loops, but here don't have another choice!!!!
 924             if (rij_shift.le.0.0D0) then
 925               evdw=1.0D20
 926               return
 927             endif
 928             sigder=-sig*sigsq
 929 c---------------------------------------------------------------
 930             rij_shift=1.0D0/rij_shift
 931             fac=rij_shift**expon
 932             e1=fac*fac*aa(itypi,itypj)
 933             e2=fac*bb(itypi,itypj)
 934             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 935             eps2der=evdwij*eps3rt
 936             eps3der=evdwij*eps2rt
 937             fac_augm=rrij**expon
 938             e_augm=augm(itypi,itypj)*fac_augm
 939             evdwij=evdwij*eps2rt*eps3rt
 940             evdw=evdw+evdwij+e_augm
 941             ij=icant(itypi,itypj)
 942             aux=eps1*eps2rt**2*eps3rt**2
 943 c            if (lprn) then
 944 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 945 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 946 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 947 c     &        restyp(itypi),i,restyp(itypj),j,
 948 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
 949 c     &        chi1,chi2,chip1,chip2,
 950 c     &        eps1,eps2rt**2,eps3rt**2,
 951 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 952 c     &        evdwij+e_augm
 953 c            endif
 954             if (calc_grad) then
 955 C Calculate gradient components.
 956             e1=e1*eps1*eps2rt**2*eps3rt**2
 957             fac=-expon*(e1+evdwij)*rij_shift
 958             sigder=fac*sigder
 959             fac=rij*fac-2*expon*rrij*e_augm
 960 C Calculate the radial part of the gradient
 961             gg(1)=xj*fac
 962             gg(2)=yj*fac
 963             gg(3)=zj*fac
 964 C Calculate angular part of the gradient.
 965             call sc_grad
 966             endif
 967           enddo      ! j
 968         enddo        ! iint
 969       enddo          ! i
 970       return
 971       end
 972 C-----------------------------------------------------------------------------
 973
 974
 975       SUBROUTINE emomo(evdw,evdw_p,evdw_m)
 976 C
 977 C This subroutine calculates the interaction energy of nonbonded side chains
 978 C assuming the Gay-Berne potential of interaction.
 979 C
 980        IMPLICIT NONE
 981        INCLUDE 'DIMENSIONS'
 982        INCLUDE 'sizesclu.dat'
 983        INCLUDE 'COMMON.CALC'
 984        INCLUDE 'COMMON.CONTROL'
 985        INCLUDE 'COMMON.CHAIN'
 986        INCLUDE 'COMMON.DERIV'
 987        INCLUDE 'COMMON.EMP'
 988        INCLUDE 'COMMON.GEO'
 989        INCLUDE 'COMMON.INTERACT'
 990        INCLUDE 'COMMON.IOUNITS'
 991        INCLUDE 'COMMON.LOCAL'
 992        INCLUDE 'COMMON.NAMES'
 993        INCLUDE 'COMMON.VAR'
 994        logical lprn
 995        double precision scalar
 996        double precision ener(4)
 997        integer troll,iint
 998
 999        energy_dec=.false.
1000        IF (energy_dec) write (iout,'(a)')
1001      & ' AAi i  AAj  j  1/rij  Rtail   Rhead   evdwij   Fcav   Ecl
1002      & Egb   Epol   Fisocav   Elj   Equad   evdw'
1003        evdw   = 0.0D0
1004        evdw_p = 0.0D0
1005        evdw_m = 0.0D0
1006 c DIAGNOSTICS
1007 ccccc      energy_dec=.false.
1008 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1009 c      lprn   = .false.
1010 c     if (icall.eq.0) lprn=.false.
1011 c END DIAGNOSTICS
1012 c      ind = 0
1013        DO i = iatsc_s, iatsc_e
1014         itypi  = itype(i)
1015 c        itypi1 = itype(i+1)
1016         dxi    = dc_norm(1,nres+i)
1017         dyi    = dc_norm(2,nres+i)
1018         dzi    = dc_norm(3,nres+i)
1019 c        dsci_inv=dsc_inv(itypi)
1020         dsci_inv = vbld_inv(i+nres)
1021 c        DO k = 1, 3
1022 c         ctail(k,1) = c(k, i+nres)
1023 c     &              - dtail(1,itypi,itypj) * dc_norm(k, nres+i)
1024 c        END DO
1025         xi=c(1,nres+i)
1026         yi=c(2,nres+i)
1027         zi=c(3,nres+i)
1028 c!-------------------------------------------------------------------
1029 C Calculate SC interaction energy.
1030         DO iint = 1, nint_gr(i)
1031          DO j = istart(i,iint), iend(i,iint)
1032 c! initialize variables for electrostatic gradients
1033           CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
1034 c            ind=ind+1
1035 c            dscj_inv = dsc_inv(itypj)
1036           dscj_inv = vbld_inv(j+nres)
1037 c! rij holds 1/(distance of Calpha atoms)
1038           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
1039           rij  = dsqrt(rrij)
1040 c!-------------------------------------------------------------------
1041 C Calculate angle-dependent terms of energy and contributions to their
1042 C derivatives.
1043
1044 #IFDEF CHECK_MOMO
1045 c!      DO troll = 10, 5000
1046 c!      om1    = 0.0d0
1047 c!      om2    = 0.0d0
1048 c!      om12   = 1.0d0
1049 c!      sqom1  = om1 * om1
1050 c!      sqom2  = om2 * om2
1051 c!      sqom12 = om12 * om12
1052 c!      rij    = 5.0d0 / troll
1053 c!      rrij   = rij * rij
1054 c!      Rtail  = troll / 5.0d0
1055 c!      Rhead  = troll / 5.0d0
1056 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1057 c!      Rtail = dsqrt((Rtail**2)
1058 c!     &      +((dabs(dtail(1,itypi,itypj)-dtail(2,itypi,itypj)))**2))
1059 c!      rij = 1.0d0/Rtail
1060 c!      rrij = rij * rij
1061 #ENDIF
1062           CALL sc_angular
1063 c! this should be in elgrad_init but om's are calculated by sc_angular
1064 c! which in turn is used by older potentials
1065 c! which proves how tangled UNRES code is >.<
1066 c! om = omega, sqom = om^2
1067           sqom1  = om1 * om1
1068           sqom2  = om2 * om2
1069           sqom12 = om12 * om12
1070
1071 c! now we calculate EGB - Gey-Berne
1072 c! It will be summed up in evdwij and saved in evdw
1073           sigsq     = 1.0D0  / sigsq
1074           sig       = sig0ij * dsqrt(sigsq)
1075 c!          rij_shift = 1.0D0  / rij - sig + sig0ij
1076           rij_shift = Rtail - sig + sig0ij
1077 c          write (2,*) "Rtal",Rtail," sig",sig," sigsq",sigsq,
1078 c     &       " sig0ij",sig0ij
1079 c          write (2,*) "rij_shift",rij_shift
1080           IF (rij_shift.le.0.0D0) THEN
1081            evdw = 1.0D20
1082            RETURN
1083           END IF
1084           sigder = -sig * sigsq
1085           rij_shift = 1.0D0 / rij_shift
1086           fac       = rij_shift**expon
1087           c1        = fac  * fac * aa(itypi,itypj)
1088 c!          c1        = 0.0d0
1089           c2        = fac  * bb(itypi,itypj)
1090 c!          c2        = 0.0d0
1091 c          write (2,*) "eps1",eps1," eps2rt",eps2rt," eps3rt",eps3rt,
1092 c     &     " c1",c1," c2",c2
1093           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
1094           eps2der   = eps3rt * evdwij
1095           eps3der   = eps2rt * evdwij
1096 c!          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
1097           evdwij    = eps2rt * eps3rt * evdwij
1098 c!      evdwij = 0.0d0
1099 c!      write (*,*) "Gey Berne = ", evdwij
1100 #ifdef TSCSC
1101           IF (bb(itypi,itypj).gt.0) THEN
1102            evdw_p = evdw_p + evdwij
1103           ELSE
1104            evdw_m = evdw_m + evdwij
1105           END IF
1106 #else
1107           evdw = evdw
1108      &         + evdwij
1109 #endif
1110 c!-------------------------------------------------------------------
1111 c! Calculate some components of GGB
1112           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
1113           fac    = -expon * (c1 + evdwij) * rij_shift
1114           sigder = fac * sigder
1115 c!          fac    = rij * fac
1116 c! Calculate distance derivative
1117 c!          gg(1) = xj * fac
1118 c!          gg(2) = yj * fac
1119 c!          gg(3) = zj * fac
1120           gg(1) = fac
1121           gg(2) = fac
1122           gg(3) = fac
1123 c!      write (*,*) "gg(1) = ", gg(1)
1124 c!      write (*,*) "gg(2) = ", gg(2)
1125 c!      write (*,*) "gg(3) = ", gg(3)
1126 c! The angular derivatives of GGB are brought together in sc_grad
1127 c!-------------------------------------------------------------------
1128 c! Fcav
1129 c!
1130 c! Catch gly-gly interactions to skip calculation of something that
1131 c! does not exist
1132
1133       IF (itypi.eq.10.and.itypj.eq.10) THEN
1134        Fcav = 0.0d0
1135        dFdR = 0.0d0
1136        dCAVdOM1  = 0.0d0
1137        dCAVdOM2  = 0.0d0
1138        dCAVdOM12 = 0.0d0
1139       ELSE
1140
1141 c! we are not 2 glycines, so we calculate Fcav (and maybe more)
1142        fac = chis1 * sqom1 + chis2 * sqom2
1143      &     - 2.0d0 * chis12 * om1 * om2 * om12
1144 c! we will use pom later in Gcav, so dont mess with it!
1145        pom = 1.0d0 - chis1 * chis2 * sqom12
1146
1147        Lambf = (1.0d0 - (fac / pom))
1148        Lambf = dsqrt(Lambf)
1149
1150
1151        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
1152 c!       write (*,*) "sparrow = ", sparrow
1153        Chif = Rtail * sparrow
1154        ChiLambf = Chif * Lambf
1155        eagle = dsqrt(ChiLambf)
1156        bat = ChiLambf ** 11.0d0
1157
1158        top = b1 * ( eagle + b2 * ChiLambf - b3 )
1159        bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
1160        botsq = bot * bot
1161
1162 c!      write (*,*) "sig1 = ",sig1
1163 c!      write (*,*) "sig2 = ",sig2
1164 c!      write (*,*) "Rtail = ",Rtail
1165 c!      write (*,*) "sparrow = ",sparrow
1166 c!      write (*,*) "Chis1 = ", chis1
1167 c!      write (*,*) "Chis2 = ", chis2
1168 c!      write (*,*) "Chis12 = ", chis12
1169 c!      write (*,*) "om1 = ", om1
1170 c!      write (*,*) "om2 = ", om2
1171 c!      write (*,*) "om12 = ", om12
1172 c!      write (*,*) "sqom1 = ", sqom1
1173 c!      write (*,*) "sqom2 = ", sqom2
1174 c!      write (*,*) "sqom12 = ", sqom12
1175 c!      write (*,*) "Lambf = ",Lambf
1176 c!      write (*,*) "b1 = ",b1
1177 c!      write (*,*) "b2 = ",b2
1178 c!      write (*,*) "b3 = ",b3
1179 c!      write (*,*) "b4 = ",b4
1180 c!      write (*,*) "top = ",top
1181 c!      write (*,*) "bot = ",bot
1182        Fcav = top / bot
1183 c!       Fcav = 0.0d0
1184 c!      write (*,*) "Fcav = ", Fcav
1185 c!-------------------------------------------------------------------
1186 c! derivative of Fcav is Gcav...
1187 c!---------------------------------------------------
1188
1189        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
1190        dbot = 12.0d0 * b4 * bat * Lambf
1191        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
1192 c!       dFdR = 0.0d0
1193 c!      write (*,*) "dFcav/dR = ", dFdR
1194
1195        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
1196        dbot = 12.0d0 * b4 * bat * Chif
1197        eagle = Lambf * pom
1198        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
1199        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
1200        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)
1201      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)
1202
1203        dFdL = ((dtop * bot - top * dbot) / botsq)
1204 c!       dFdL = 0.0d0
1205        dCAVdOM1  = dFdL * ( dFdOM1 )
1206        dCAVdOM2  = dFdL * ( dFdOM2 )
1207        dCAVdOM12 = dFdL * ( dFdOM12 )
1208 c!      write (*,*) "dFcav/dOM1 = ", dCAVdOM1
1209 c!      write (*,*) "dFcav/dOM2 = ", dCAVdOM2
1210 c!      write (*,*) "dFcav/dOM12 = ", dCAVdOM12
1211 c!      write (*,*) ""
1212 c!-------------------------------------------------------------------
1213 c! Finally, add the distance derivatives of GB and Fcav to gvdwc
1214 c! Pom is used here to project the gradient vector into
1215 c! cartesian coordinates and at the same time contains
1216 c! dXhb/dXsc derivative (for charged amino acids
1217 c! location of hydrophobic centre of interaction is not
1218 c! the same as geometric centre of side chain, this
1219 c! derivative takes that into account)
1220 c! derivatives of omega angles will be added in sc_grad
1221
1222        DO k= 1, 3
1223         ertail(k) = Rtail_distance(k)/Rtail
1224        END DO
1225        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
1226        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
1227        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1228        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1229        DO k = 1, 3
1230 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1231 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1232         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
1233         gvdwx(k,i) = gvdwx(k,i)
1234      &             - (( dFdR + gg(k) ) * pom)
1235 c!     &             - ( dFdR * pom )
1236         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
1237         gvdwx(k,j) = gvdwx(k,j)
1238      &             + (( dFdR + gg(k) ) * pom)
1239 c!     &             + ( dFdR * pom )
1240
1241         gvdwc(k,i) = gvdwc(k,i)
1242      &             - (( dFdR + gg(k) ) * ertail(k))
1243 c!     &             - ( dFdR * ertail(k))
1244
1245         gvdwc(k,j) = gvdwc(k,j)
1246      &             + (( dFdR + gg(k) ) * ertail(k))
1247 c!     &             + ( dFdR * ertail(k))
1248
1249         gg(k) = 0.0d0
1250 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1251 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1252       END DO
1253
1254 c!-------------------------------------------------------------------
1255 c! Compute head-head and head-tail energies for each state
1256
1257           isel = iabs(Qi) + iabs(Qj)
1258           IF (isel.eq.0) THEN
1259 c! No charges - do nothing
1260            eheadtail = 0.0d0
1261
1262           ELSE IF (isel.eq.4) THEN
1263 c! Calculate dipole-dipole interactions
1264            CALL edd(ecl)
1265            eheadtail = ECL
1266
1267           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
1268 c! Charge-nonpolar interactions
1269            CALL eqn(epol)
1270            eheadtail = epol
1271
1272           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
1273 c! Nonpolar-charge interactions
1274            CALL enq(epol)
1275            eheadtail = epol
1276
1277           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
1278 c! Charge-dipole interactions
1279            CALL eqd(ecl, elj, epol)
1280            eheadtail = ECL + elj + epol
1281
1282           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
1283 c! Dipole-charge interactions
1284            CALL edq(ecl, elj, epol)
1285            eheadtail = ECL + elj + epol
1286
1287           ELSE IF ((isel.eq.2.and.
1288      &          iabs(Qi).eq.1).and.
1289      &          nstate(itypi,itypj).eq.1) THEN
1290 c! Same charge-charge interaction ( +/+ or -/- )
1291            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
1292            eheadtail = ECL + Egb + Epol + Fisocav + Elj
1293
1294           ELSE IF ((isel.eq.2.and.
1295      &          iabs(Qi).eq.1).and.
1296      &          nstate(itypi,itypj).ne.1) THEN
1297 c! Different charge-charge interaction ( +/- or -/+ )
1298            CALL energy_quad
1299      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1300           END IF
1301        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
1302 c!      write (*,*) "evdw = ", evdw
1303 c!      write (*,*) "Fcav = ", Fcav
1304 c!      write (*,*) "eheadtail = ", eheadtail
1305        evdw = evdw
1306      &      + Fcav
1307      &      + eheadtail
1308        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,9f16.7)')
1309      &  restyp(itype(i)),i,restyp(itype(j)),j,
1310      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1311      &  Equad,evdw
1312        IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
1313      &  restyp(itype(i)),i,restyp(itype(j)),j,
1314      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1315      &  Equad,evdw
1316 #IFDEF CHECK_MOMO
1317        evdw = 0.0d0
1318        END DO ! troll
1319 #ENDIF
1320
1321 c!-------------------------------------------------------------------
1322 c! As all angular derivatives are done, now we sum them up,
1323 c! then transform and project into cartesian vectors and add to gvdwc
1324 c! We call sc_grad always, with the exception of +/- interaction.
1325 c! This is because energy_quad subroutine needs to handle
1326 c! this job in his own way.
1327 c! This IS probably not very efficient and SHOULD be optimised
1328 c! but it will require major restructurization of emomo
1329 c! so it will be left as it is for now
1330 c!       write (*,*) 'troll1, nstate =', nstate (itypi,itypj)
1331        IF (nstate(itypi,itypj).eq.1) THEN
1332 #ifdef TSCSC
1333         IF (bb(itypi,itypj).gt.0) THEN
1334          CALL sc_grad
1335         ELSE
1336          CALL sc_grad_T
1337         END IF
1338 #else
1339         CALL sc_grad
1340 #endif
1341        END IF
1342 c!-------------------------------------------------------------------
1343 c! NAPISY KONCOWE
1344          END DO   ! j
1345         END DO    ! iint
1346        END DO     ! i
1347 c      write (iout,*) "Number of loop steps in EGB:",ind
1348 c      energy_dec=.false.
1349        RETURN
1350       END SUBROUTINE emomo
1351 c! END OF MOMO
1352
1353
1354 C-----------------------------------------------------------------------------
1355
1356
1357       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
1358        IMPLICIT NONE
1359        INCLUDE 'DIMENSIONS'
1360        INCLUDE 'sizesclu.dat'
1361        INCLUDE 'COMMON.CALC'
1362        INCLUDE 'COMMON.CHAIN'
1363        INCLUDE 'COMMON.CONTROL'
1364        INCLUDE 'COMMON.DERIV'
1365        INCLUDE 'COMMON.EMP'
1366        INCLUDE 'COMMON.GEO'
1367        INCLUDE 'COMMON.INTERACT'
1368        INCLUDE 'COMMON.IOUNITS'
1369        INCLUDE 'COMMON.LOCAL'
1370        INCLUDE 'COMMON.NAMES'
1371        INCLUDE 'COMMON.VAR'
1372        double precision scalar, facd3, facd4, federmaus, adler
1373 c! Epol and Gpol analytical parameters
1374        alphapol1 = alphapol(itypi,itypj)
1375        alphapol2 = alphapol(itypj,itypi)
1376 c! Fisocav and Gisocav analytical parameters
1377        al1  = alphiso(1,itypi,itypj)
1378        al2  = alphiso(2,itypi,itypj)
1379        al3  = alphiso(3,itypi,itypj)
1380        al4  = alphiso(4,itypi,itypj)
1381        csig = (1.0d0
1382      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1383      &      + sigiso2(itypi,itypj)**2.0d0))
1384 c!
1385        pis  = sig0head(itypi,itypj)
1386        eps_head = epshead(itypi,itypj)
1387        Rhead_sq = Rhead * Rhead
1388 c! R1 - distance between head of ith side chain and tail of jth sidechain
1389 c! R2 - distance between head of jth side chain and tail of ith sidechain
1390        R1 = 0.0d0
1391        R2 = 0.0d0
1392        DO k = 1, 3
1393 c! Calculate head-to-tail distances needed by Epol
1394         R1=R1+(ctail(k,2)-chead(k,1))**2
1395         R2=R2+(chead(k,2)-ctail(k,1))**2
1396        END DO
1397 c! Pitagoras
1398        R1 = dsqrt(R1)
1399        R2 = dsqrt(R2)
1400
1401 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1402 c!     &        +dhead(1,1,itypi,itypj))**2))
1403 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1404 c!     &        +dhead(2,1,itypi,itypj))**2))
1405
1406 c!-------------------------------------------------------------------
1407 c! Coulomb electrostatic interaction
1408        Ecl = (332.0d0 * Qij) / Rhead
1409 c! derivative of Ecl is Gcl...
1410        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
1411        dGCLdOM1 = 0.0d0
1412        dGCLdOM2 = 0.0d0
1413        dGCLdOM12 = 0.0d0
1414 c!-------------------------------------------------------------------
1415 c! Generalised Born Solvent Polarization
1416 c! Charged head polarizes the solvent
1417        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1418        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1419        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1420 c! Derivative of Egb is Ggb...
1421        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1422        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1423      &        / ( 2.0d0 * Fgb )
1424        dGGBdR = dGGBdFGB * dFGBdR
1425 c!-------------------------------------------------------------------
1426 c! Fisocav - isotropic cavity creation term
1427 c! or "how much energy it costs to put charged head in water"
1428        pom = Rhead * csig
1429        top = al1 * (dsqrt(pom) + al2 * pom - al3)
1430        bot = (1.0d0 + al4 * pom**12.0d0)
1431        botsq = bot * bot
1432        FisoCav = top / bot
1433 c!      write (*,*) "Rhead = ",Rhead
1434 c!      write (*,*) "csig = ",csig
1435 c!      write (*,*) "pom = ",pom
1436 c!      write (*,*) "al1 = ",al1
1437 c!      write (*,*) "al2 = ",al2
1438 c!      write (*,*) "al3 = ",al3
1439 c!      write (*,*) "al4 = ",al4
1440 c!      write (*,*) "top = ",top
1441 c!      write (*,*) "bot = ",bot
1442 c! Derivative of Fisocav is GCV...
1443        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1444        dbot = 12.0d0 * al4 * pom ** 11.0d0
1445        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1446 c!-------------------------------------------------------------------
1447 c! Epol
1448 c! Polarization energy - charged heads polarize hydrophobic "neck"
1449        MomoFac1 = (1.0d0 - chi1 * sqom2)
1450        MomoFac2 = (1.0d0 - chi2 * sqom1)
1451        RR1  = ( R1 * R1 ) / MomoFac1
1452        RR2  = ( R2 * R2 ) / MomoFac2
1453        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1454        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1455        fgb1 = sqrt( RR1 + a12sq * ee1 )
1456        fgb2 = sqrt( RR2 + a12sq * ee2 )
1457        epol = 332.0d0 * eps_inout_fac * (
1458      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1459 c!       epol = 0.0d0
1460 c       write (*,*) "eps_inout_fac = ",eps_inout_fac
1461 c       write (*,*) "alphapol1 = ", alphapol1
1462 c       write (*,*) "alphapol2 = ", alphapol2
1463 c       write (*,*) "fgb1 = ", fgb1
1464 c       write (*,*) "fgb2 = ", fgb2
1465 c       write (*,*) "epol = ", epol
1466 c! derivative of Epol is Gpol...
1467        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1468      &          / (fgb1 ** 5.0d0)
1469        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1470      &          / (fgb2 ** 5.0d0)
1471        dFGBdR1 = ( (R1 / MomoFac1)
1472      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
1473      &        / ( 2.0d0 * fgb1 )
1474        dFGBdR2 = ( (R2 / MomoFac2)
1475      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
1476      &        / ( 2.0d0 * fgb2 )
1477        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1478      &          * ( 2.0d0 - 0.5d0 * ee1) )
1479      &          / ( 2.0d0 * fgb1 )
1480        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1481      &          * ( 2.0d0 - 0.5d0 * ee2) )
1482      &          / ( 2.0d0 * fgb2 )
1483        dPOLdR1 = dPOLdFGB1 * dFGBdR1
1484 c!       dPOLdR1 = 0.0d0
1485        dPOLdR2 = dPOLdFGB2 * dFGBdR2
1486 c!       dPOLdR2 = 0.0d0
1487        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1488 c!       dPOLdOM1 = 0.0d0
1489        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1490 c!       dPOLdOM2 = 0.0d0
1491 c!-------------------------------------------------------------------
1492 c! Elj
1493 c! Lennard-Jones 6-12 interaction between heads
1494        pom = (pis / Rhead)**6.0d0
1495        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1496 c! derivative of Elj is Glj
1497        dGLJdR = 4.0d0 * eps_head
1498      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1499      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1500 c!-------------------------------------------------------------------
1501 c! Return the results
1502 c! These things do the dRdX derivatives, that is
1503 c! allow us to change what we see from function that changes with
1504 c! distance to function that changes with LOCATION (of the interaction
1505 c! site)
1506        DO k = 1, 3
1507         erhead(k) = Rhead_distance(k)/Rhead
1508         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1509         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1510        END DO
1511
1512        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1513        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1514        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1515        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1516        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1517        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1518        facd1 = d1 * vbld_inv(i+nres)
1519        facd2 = d2 * vbld_inv(j+nres)
1520        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1521        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1522
1523 c! Now we add appropriate partial derivatives (one in each dimension)
1524        DO k = 1, 3
1525         hawk   = (erhead_tail(k,1) +
1526      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
1527         condor = (erhead_tail(k,2) +
1528      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
1529
1530         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1531         gvdwx(k,i) = gvdwx(k,i)
1532      &             - dGCLdR * pom
1533      &             - dGGBdR * pom
1534      &             - dGCVdR * pom
1535      &             - dPOLdR1 * hawk
1536      &             - dPOLdR2 * (erhead_tail(k,2)
1537      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1538      &             - dGLJdR * pom
1539
1540         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1541         gvdwx(k,j) = gvdwx(k,j)
1542      &             + dGCLdR * pom
1543      &             + dGGBdR * pom
1544      &             + dGCVdR * pom
1545      &             + dPOLdR1 * (erhead_tail(k,1)
1546      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1547      &             + dPOLdR2 * condor
1548      &             + dGLJdR * pom
1549
1550         gvdwc(k,i) = gvdwc(k,i)
1551      &             - dGCLdR * erhead(k)
1552      &             - dGGBdR * erhead(k)
1553      &             - dGCVdR * erhead(k)
1554      &             - dPOLdR1 * erhead_tail(k,1)
1555      &             - dPOLdR2 * erhead_tail(k,2)
1556      &             - dGLJdR * erhead(k)
1557
1558         gvdwc(k,j) = gvdwc(k,j)
1559      &             + dGCLdR * erhead(k)
1560      &             + dGGBdR * erhead(k)
1561      &             + dGCVdR * erhead(k)
1562      &             + dPOLdR1 * erhead_tail(k,1)
1563      &             + dPOLdR2 * erhead_tail(k,2)
1564      &             + dGLJdR * erhead(k)
1565
1566        END DO
1567        RETURN
1568       END SUBROUTINE eqq
1569 c!-------------------------------------------------------------------
1570       SUBROUTINE energy_quad
1571      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1572        IMPLICIT NONE
1573        INCLUDE 'DIMENSIONS'
1574        INCLUDE 'sizesclu.dat'
1575        INCLUDE 'COMMON.CALC'
1576        INCLUDE 'COMMON.CHAIN'
1577        INCLUDE 'COMMON.CONTROL'
1578        INCLUDE 'COMMON.DERIV'
1579        INCLUDE 'COMMON.EMP'
1580        INCLUDE 'COMMON.GEO'
1581        INCLUDE 'COMMON.INTERACT'
1582        INCLUDE 'COMMON.IOUNITS'
1583        INCLUDE 'COMMON.LOCAL'
1584        INCLUDE 'COMMON.NAMES'
1585        INCLUDE 'COMMON.VAR'
1586        double precision scalar
1587        double precision ener(4)
1588        double precision dcosom1(3),dcosom2(3)
1589 c! used in Epol derivatives
1590        double precision facd3, facd4
1591        double precision federmaus, adler
1592 c! Epol and Gpol analytical parameters
1593        alphapol1 = alphapol(itypi,itypj)
1594        alphapol2 = alphapol(itypj,itypi)
1595 c! Fisocav and Gisocav analytical parameters
1596        al1  = alphiso(1,itypi,itypj)
1597        al2  = alphiso(2,itypi,itypj)
1598        al3  = alphiso(3,itypi,itypj)
1599        al4  = alphiso(4,itypi,itypj)
1600        csig = (1.0d0
1601      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1602      &      + sigiso2(itypi,itypj)**2.0d0))
1603 c!
1604        w1   = wqdip(1,itypi,itypj)
1605        w2   = wqdip(2,itypi,itypj)
1606        pis  = sig0head(itypi,itypj)
1607        eps_head = epshead(itypi,itypj)
1608 c! First things first:
1609 c! We need to do sc_grad's job with GB and Fcav
1610        eom1  =
1611      &         eps2der * eps2rt_om1
1612      &       - 2.0D0 * alf1 * eps3der
1613      &       + sigder * sigsq_om1
1614      &       + dCAVdOM1
1615        eom2  =
1616      &         eps2der * eps2rt_om2
1617      &       + 2.0D0 * alf2 * eps3der
1618      &       + sigder * sigsq_om2
1619      &       + dCAVdOM2
1620        eom12 =
1621      &         evdwij  * eps1_om12
1622      &       + eps2der * eps2rt_om12
1623      &       - 2.0D0 * alf12 * eps3der
1624      &       + sigder *sigsq_om12
1625      &       + dCAVdOM12
1626 c! now some magical transformations to project gradient into
1627 c! three cartesian vectors
1628        DO k = 1, 3
1629         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1630         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1631         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
1632 c! this acts on hydrophobic center of interaction
1633         gvdwx(k,i)= gvdwx(k,i) - gg(k)
1634      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1635      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1636         gvdwx(k,j)= gvdwx(k,j) + gg(k)
1637      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1638      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1639 c! this acts on Calpha
1640         gvdwc(k,i)=gvdwc(k,i)-gg(k)
1641         gvdwc(k,j)=gvdwc(k,j)+gg(k)
1642        END DO
1643 c! sc_grad is done, now we will compute
1644        eheadtail = 0.0d0
1645        eom1 = 0.0d0
1646        eom2 = 0.0d0
1647        eom12 = 0.0d0
1648
1649 c! ENERGY DEBUG
1650 c!       ii = 1
1651 c!       jj = 1
1652 c!       d1 = dhead(1, 1, itypi, itypj)
1653 c!       d2 = dhead(2, 1, itypi, itypj)
1654 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1655 c!     &        +dhead(1,ii,itypi,itypj))**2))
1656 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1657 c!     &        +dhead(2,jj,itypi,itypj))**2))
1658 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1659 c! END OF ENERGY DEBUG
1660 c*************************************************************
1661        DO istate = 1, nstate(itypi,itypj)
1662 c*************************************************************
1663         IF (istate.ne.1) THEN
1664          IF (istate.lt.3) THEN
1665           ii = 1
1666          ELSE
1667           ii = 2
1668          END IF
1669         jj = istate/ii
1670         d1 = dhead(1,ii,itypi,itypj)
1671         d2 = dhead(2,jj,itypi,itypj)
1672         DO k = 1,3
1673          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
1674          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
1675          Rhead_distance(k) = chead(k,2) - chead(k,1)
1676         END DO
1677 c! pitagoras (root of sum of squares)
1678         Rhead = dsqrt(
1679      &          (Rhead_distance(1)*Rhead_distance(1))
1680      &        + (Rhead_distance(2)*Rhead_distance(2))
1681      &        + (Rhead_distance(3)*Rhead_distance(3)))
1682         END IF
1683         Rhead_sq = Rhead * Rhead
1684
1685 c! R1 - distance between head of ith side chain and tail of jth sidechain
1686 c! R2 - distance between head of jth side chain and tail of ith sidechain
1687         R1 = 0.0d0
1688         R2 = 0.0d0
1689         DO k = 1, 3
1690 c! Calculate head-to-tail distances
1691          R1=R1+(ctail(k,2)-chead(k,1))**2
1692          R2=R2+(chead(k,2)-ctail(k,1))**2
1693         END DO
1694 c! Pitagoras
1695         R1 = dsqrt(R1)
1696         R2 = dsqrt(R2)
1697
1698 c! ENERGY DEBUG
1699 c!      write (*,*) "istate = ", istate
1700 c!      write (*,*) "ii = ", ii
1701 c!      write (*,*) "jj = ", jj
1702 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1703 c!     &        +dhead(1,ii,itypi,itypj))**2))
1704 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1705 c!     &        +dhead(2,jj,itypi,itypj))**2))
1706 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1707 c!      Rhead_sq = Rhead * Rhead
1708 c!      write (*,*) "d1 = ",d1
1709 c!      write (*,*) "d2 = ",d2
1710 c!      write (*,*) "R1 = ",R1
1711 c!      write (*,*) "R2 = ",R2
1712 c!      write (*,*) "Rhead = ",Rhead
1713 c! END OF ENERGY DEBUG
1714
1715 c!-------------------------------------------------------------------
1716 c! Coulomb electrostatic interaction
1717         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
1718 c!        Ecl = 0.0d0
1719 c!        write (*,*) "Ecl = ", Ecl
1720 c! derivative of Ecl is Gcl...
1721         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
1722 c!        dGCLdR = 0.0d0
1723         dGCLdOM1 = 0.0d0
1724         dGCLdOM2 = 0.0d0
1725         dGCLdOM12 = 0.0d0
1726 c!-------------------------------------------------------------------
1727 c! Generalised Born Solvent Polarization
1728         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1729         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1730         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1731 c!        Egb = 0.0d0
1732 c!      write (*,*) "a1*a2 = ", a12sq
1733 c!      write (*,*) "Rhead = ", Rhead
1734 c!      write (*,*) "Rhead_sq = ", Rhead_sq
1735 c!      write (*,*) "ee = ", ee
1736 c!      write (*,*) "Fgb = ", Fgb
1737 c!      write (*,*) "fac = ", eps_inout_fac
1738 c!      write (*,*) "Qij = ", Qij
1739 c!      write (*,*) "Egb = ", Egb
1740 c! Derivative of Egb is Ggb...
1741 c! dFGBdR is used by Quad's later...
1742         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1743         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1744      &         / ( 2.0d0 * Fgb )
1745         dGGBdR = dGGBdFGB * dFGBdR
1746 c!        dGGBdR = 0.0d0
1747 c!-------------------------------------------------------------------
1748 c! Fisocav - isotropic cavity creation term
1749         pom = Rhead * csig
1750         top = al1 * (dsqrt(pom) + al2 * pom - al3)
1751         bot = (1.0d0 + al4 * pom**12.0d0)
1752         botsq = bot * bot
1753         FisoCav = top / bot
1754 c!        FisoCav = 0.0d0
1755 c!      write (*,*) "pom = ",pom
1756 c!      write (*,*) "al1 = ",al1
1757 c!      write (*,*) "al2 = ",al2
1758 c!      write (*,*) "al3 = ",al3
1759 c!      write (*,*) "al4 = ",al4
1760 c!      write (*,*) "top = ",top
1761 c!      write (*,*) "bot = ",bot
1762 c!      write (*,*) "Fisocav = ", Fisocav
1763
1764 c! Derivative of Fisocav is GCV...
1765         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1766         dbot = 12.0d0 * al4 * pom ** 11.0d0
1767         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1768 c!        dGCVdR = 0.0d0
1769 c!-------------------------------------------------------------------
1770 c! Polarization energy
1771 c! Epol
1772         MomoFac1 = (1.0d0 - chi1 * sqom2)
1773         MomoFac2 = (1.0d0 - chi2 * sqom1)
1774         RR1  = ( R1 * R1 ) / MomoFac1
1775         RR2  = ( R2 * R2 ) / MomoFac2
1776         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1777         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1778         fgb1 = sqrt( RR1 + a12sq * ee1 )
1779         fgb2 = sqrt( RR2 + a12sq * ee2 )
1780         epol = 332.0d0 * eps_inout_fac * (
1781      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1782 c!        epol = 0.0d0
1783 c! derivative of Epol is Gpol...
1784         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1785      &            / (fgb1 ** 5.0d0)
1786         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1787      &            / (fgb2 ** 5.0d0)
1788         dFGBdR1 = ( (R1 / MomoFac1)
1789      &          * ( 2.0d0 - (0.5d0 * ee1) ) )
1790      &          / ( 2.0d0 * fgb1 )
1791         dFGBdR2 = ( (R2 / MomoFac2)
1792      &          * ( 2.0d0 - (0.5d0 * ee2) ) )
1793      &          / ( 2.0d0 * fgb2 )
1794         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1795      &           * ( 2.0d0 - 0.5d0 * ee1) )
1796      &           / ( 2.0d0 * fgb1 )
1797         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1798      &           * ( 2.0d0 - 0.5d0 * ee2) )
1799      &           / ( 2.0d0 * fgb2 )
1800         dPOLdR1 = dPOLdFGB1 * dFGBdR1
1801 c!        dPOLdR1 = 0.0d0
1802         dPOLdR2 = dPOLdFGB2 * dFGBdR2
1803 c!        dPOLdR2 = 0.0d0
1804         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1805 c!        dPOLdOM1 = 0.0d0
1806         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1807 c!        dPOLdOM2 = 0.0d0
1808 c!-------------------------------------------------------------------
1809 c! Elj
1810         pom = (pis / Rhead)**6.0d0
1811         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1812 c!        Elj = 0.0d0
1813 c! derivative of Elj is Glj
1814         dGLJdR = 4.0d0 * eps_head
1815      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1816      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1817 c!        dGLJdR = 0.0d0
1818 c!-------------------------------------------------------------------
1819 c! Equad
1820        IF (Wqd.ne.0.0d0) THEN
1821         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)
1822      &        - 37.5d0  * ( sqom1 + sqom2 )
1823      &        + 157.5d0 * ( sqom1 * sqom2 )
1824      &        - 45.0d0  * om1*om2*om12
1825         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
1826         Equad = fac * Beta1
1827 c!        Equad = 0.0d0
1828 c! derivative of Equad...
1829         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
1830 c!        dQUADdR = 0.0d0
1831         dQUADdOM1 = fac
1832      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
1833 c!        dQUADdOM1 = 0.0d0
1834         dQUADdOM2 = fac
1835      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
1836 c!        dQUADdOM2 = 0.0d0
1837         dQUADdOM12 = fac
1838      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )
1839 c!        dQUADdOM12 = 0.0d0
1840         ELSE
1841          Beta1 = 0.0d0
1842          Equad = 0.0d0
1843         END IF
1844 c!-------------------------------------------------------------------
1845 c! Return the results
1846 c! Angular stuff
1847         eom1 = dPOLdOM1 + dQUADdOM1
1848         eom2 = dPOLdOM2 + dQUADdOM2
1849         eom12 = dQUADdOM12
1850 c! now some magical transformations to project gradient into
1851 c! three cartesian vectors
1852         DO k = 1, 3
1853          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1854          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1855          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
1856         END DO
1857 c! Radial stuff
1858         DO k = 1, 3
1859          erhead(k) = Rhead_distance(k)/Rhead
1860          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1861          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1862         END DO
1863         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1864         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1865         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1866         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1867         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1868         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1869         facd1 = d1 * vbld_inv(i+nres)
1870         facd2 = d2 * vbld_inv(j+nres)
1871         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1872         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1873 c! Throw the results into gheadtail which holds gradients
1874 c! for each micro-state
1875         DO k = 1, 3
1876          hawk   = erhead_tail(k,1) +
1877      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
1878          condor = erhead_tail(k,2) +
1879      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
1880
1881          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1882 c! this acts on hydrophobic center of interaction
1883          gheadtail(k,1,1) = gheadtail(k,1,1)
1884      &                    - dGCLdR * pom
1885      &                    - dGGBdR * pom
1886      &                    - dGCVdR * pom
1887      &                    - dPOLdR1 * hawk
1888      &                    - dPOLdR2 * (erhead_tail(k,2)
1889      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1890      &                    - dGLJdR * pom
1891      &                    - dQUADdR * pom
1892      &                    - tuna(k)
1893      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1894      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1895
1896          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1897 c! this acts on hydrophobic center of interaction
1898          gheadtail(k,2,1) = gheadtail(k,2,1)
1899      &                    + dGCLdR * pom
1900      &                    + dGGBdR * pom
1901      &                    + dGCVdR * pom
1902      &                    + dPOLdR1 * (erhead_tail(k,1)
1903      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1904      &                    + dPOLdR2 * condor
1905      &                    + dGLJdR * pom
1906      &                    + dQUADdR * pom
1907      &                    + tuna(k)
1908      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1909      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1910
1911 c! this acts on Calpha
1912          gheadtail(k,3,1) = gheadtail(k,3,1)
1913      &                    - dGCLdR * erhead(k)
1914      &                    - dGGBdR * erhead(k)
1915      &                    - dGCVdR * erhead(k)
1916      &                    - dPOLdR1 * erhead_tail(k,1)
1917      &                    - dPOLdR2 * erhead_tail(k,2)
1918      &                    - dGLJdR * erhead(k)
1919      &                    - dQUADdR * erhead(k)
1920      &                    - tuna(k)
1921
1922 c! this acts on Calpha
1923          gheadtail(k,4,1) = gheadtail(k,4,1)
1924      &                    + dGCLdR * erhead(k)
1925      &                    + dGGBdR * erhead(k)
1926      &                    + dGCVdR * erhead(k)
1927      &                    + dPOLdR1 * erhead_tail(k,1)
1928      &                    + dPOLdR2 * erhead_tail(k,2)
1929      &                    + dGLJdR * erhead(k)
1930      &                    + dQUADdR * erhead(k)
1931      &                    + tuna(k)
1932         END DO
1933 c!      write(*,*) "ECL = ", Ecl
1934 c!      write(*,*) "Egb = ", Egb
1935 c!      write(*,*) "Epol = ", Epol
1936 c!      write(*,*) "Fisocav = ", Fisocav
1937 c!      write(*,*) "Elj = ", Elj
1938 c!      write(*,*) "Equad = ", Equad
1939 c!      write(*,*) "wstate = ", wstate(istate,itypi,itypj)
1940 c!      write(*,*) "eheadtail = ", eheadtail
1941 c!      write(*,*) "TROLL = ", dexp(-betaTT * ener(istate))
1942 c!      write(*,*) "dGCLdR = ", dGCLdR
1943 c!      write(*,*) "dGGBdR = ", dGGBdR
1944 c!      write(*,*) "dGCVdR = ", dGCVdR
1945 c!      write(*,*) "dPOLdR1 = ", dPOLdR1
1946 c!      write(*,*) "dPOLdR2 = ", dPOLdR2
1947 c!      write(*,*) "dGLJdR = ", dGLJdR
1948 c!      write(*,*) "dQUADdR = ", dQUADdR
1949 c!      write(*,*) "tuna(",k,") = ", tuna(k)
1950         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
1951         eheadtail = eheadtail
1952      &            + wstate(istate, itypi, itypj)
1953      &            * dexp(-betaTT * ener(istate))
1954 c! foreach cartesian dimension
1955         DO k = 1, 3
1956 c! foreach of two gvdwx and gvdwc
1957          DO l = 1, 4
1958           gheadtail(k,l,2) = gheadtail(k,l,2)
1959      &                     + wstate( istate, itypi, itypj )
1960      &                     * dexp(-betaTT * ener(istate))
1961      &                     * gheadtail(k,l,1)
1962           gheadtail(k,l,1) = 0.0d0
1963          END DO
1964         END DO
1965        END DO
1966 c! Here ended the gigantic DO istate = 1, 4, which starts
1967 c! at the beggining of the subroutine
1968
1969        DO k = 1, 3
1970         DO l = 1, 4
1971          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
1972         END DO
1973         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
1974         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
1975         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
1976         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
1977         DO l = 1, 4
1978          gheadtail(k,l,1) = 0.0d0
1979          gheadtail(k,l,2) = 0.0d0
1980         END DO
1981        END DO
1982        eheadtail = (-dlog(eheadtail)) / betaTT
1983        dPOLdOM1 = 0.0d0
1984        dPOLdOM2 = 0.0d0
1985        dQUADdOM1 = 0.0d0
1986        dQUADdOM2 = 0.0d0
1987        dQUADdOM12 = 0.0d0
1988        RETURN
1989       END SUBROUTINE energy_quad
1990
1991
1992 c!-------------------------------------------------------------------
1993
1994
1995       SUBROUTINE eqn(Epol)
1996       IMPLICIT NONE
1997       INCLUDE 'DIMENSIONS'
1998       INCLUDE 'sizesclu.dat'
1999       INCLUDE 'COMMON.CALC'
2000       INCLUDE 'COMMON.CHAIN'
2001       INCLUDE 'COMMON.CONTROL'
2002       INCLUDE 'COMMON.DERIV'
2003       INCLUDE 'COMMON.EMP'
2004       INCLUDE 'COMMON.GEO'
2005       INCLUDE 'COMMON.INTERACT'
2006       INCLUDE 'COMMON.IOUNITS'
2007       INCLUDE 'COMMON.LOCAL'
2008       INCLUDE 'COMMON.NAMES'
2009       INCLUDE 'COMMON.VAR'
2010       double precision scalar, facd4, federmaus
2011       alphapol1 = alphapol(itypi,itypj)
2012 c! R1 - distance between head of ith side chain and tail of jth sidechain
2013        R1 = 0.0d0
2014        DO k = 1, 3
2015 c! Calculate head-to-tail distances
2016         R1=R1+(ctail(k,2)-chead(k,1))**2
2017        END DO
2018 c! Pitagoras
2019        R1 = dsqrt(R1)
2020
2021 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2022 c!     &        +dhead(1,1,itypi,itypj))**2))
2023 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2024 c!     &        +dhead(2,1,itypi,itypj))**2))
2025 c--------------------------------------------------------------------
2026 c Polarization energy
2027 c Epol
2028        MomoFac1 = (1.0d0 - chi1 * sqom2)
2029        RR1  = R1 * R1 / MomoFac1
2030        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2031        fgb1 = sqrt( RR1 + a12sq * ee1)
2032        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2033 c!       epol = 0.0d0
2034 c!------------------------------------------------------------------
2035 c! derivative of Epol is Gpol...
2036        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2037      &          / (fgb1 ** 5.0d0)
2038        dFGBdR1 = ( (R1 / MomoFac1)
2039      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2040      &        / ( 2.0d0 * fgb1 )
2041        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2042      &          * (2.0d0 - 0.5d0 * ee1) )
2043      &          / (2.0d0 * fgb1)
2044        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2045 c!       dPOLdR1 = 0.0d0
2046        dPOLdOM1 = 0.0d0
2047        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2048 c!       dPOLdOM2 = 0.0d0
2049 c!-------------------------------------------------------------------
2050 c! Return the results
2051 c! (see comments in Eqq)
2052        DO k = 1, 3
2053         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2054        END DO
2055        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2056        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2057        facd1 = d1 * vbld_inv(i+nres)
2058        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2059
2060        DO k = 1, 3
2061         hawk = (erhead_tail(k,1) +
2062      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2063
2064         gvdwx(k,i) = gvdwx(k,i)
2065      &             - dPOLdR1 * hawk
2066         gvdwx(k,j) = gvdwx(k,j)
2067      &             + dPOLdR1 * (erhead_tail(k,1)
2068      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2069
2070         gvdwc(k,i) = gvdwc(k,i)
2071      &             - dPOLdR1 * erhead_tail(k,1)
2072         gvdwc(k,j) = gvdwc(k,j)
2073      &             + dPOLdR1 * erhead_tail(k,1)
2074
2075        END DO
2076        RETURN
2077       END SUBROUTINE eqn
2078
2079
2080 c!-------------------------------------------------------------------
2081
2082
2083
2084       SUBROUTINE enq(Epol)
2085        IMPLICIT NONE
2086        INCLUDE 'DIMENSIONS'
2087        INCLUDE 'sizesclu.dat'
2088        INCLUDE 'COMMON.CALC'
2089        INCLUDE 'COMMON.CHAIN'
2090        INCLUDE 'COMMON.CONTROL'
2091        INCLUDE 'COMMON.DERIV'
2092        INCLUDE 'COMMON.EMP'
2093        INCLUDE 'COMMON.GEO'
2094        INCLUDE 'COMMON.INTERACT'
2095        INCLUDE 'COMMON.IOUNITS'
2096        INCLUDE 'COMMON.LOCAL'
2097        INCLUDE 'COMMON.NAMES'
2098        INCLUDE 'COMMON.VAR'
2099        double precision scalar, facd3, adler
2100        alphapol2 = alphapol(itypj,itypi)
2101 c! R2 - distance between head of jth side chain and tail of ith sidechain
2102        R2 = 0.0d0
2103        DO k = 1, 3
2104 c! Calculate head-to-tail distances
2105         R2=R2+(chead(k,2)-ctail(k,1))**2
2106        END DO
2107 c! Pitagoras
2108        R2 = dsqrt(R2)
2109
2110 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2111 c!     &        +dhead(1,1,itypi,itypj))**2))
2112 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2113 c!     &        +dhead(2,1,itypi,itypj))**2))
2114 c------------------------------------------------------------------------
2115 c Polarization energy
2116        MomoFac2 = (1.0d0 - chi2 * sqom1)
2117        RR2  = R2 * R2 / MomoFac2
2118        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2119        fgb2 = sqrt(RR2  + a12sq * ee2)
2120        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2121 c!       epol = 0.0d0
2122 c!-------------------------------------------------------------------
2123 c! derivative of Epol is Gpol...
2124        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2125      &          / (fgb2 ** 5.0d0)
2126        dFGBdR2 = ( (R2 / MomoFac2)
2127      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2128      &        / (2.0d0 * fgb2)
2129        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2130      &          * (2.0d0 - 0.5d0 * ee2) )
2131      &          / (2.0d0 * fgb2)
2132        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2133 c!       dPOLdR2 = 0.0d0
2134        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2135 c!       dPOLdOM1 = 0.0d0
2136        dPOLdOM2 = 0.0d0
2137 c!-------------------------------------------------------------------
2138 c! Return the results
2139 c! (See comments in Eqq)
2140        DO k = 1, 3
2141         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2142        END DO
2143        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2144        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2145        facd2 = d2 * vbld_inv(j+nres)
2146        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2147        DO k = 1, 3
2148         condor = (erhead_tail(k,2)
2149      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2150
2151         gvdwx(k,i) = gvdwx(k,i)
2152      &             - dPOLdR2 * (erhead_tail(k,2)
2153      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2154         gvdwx(k,j) = gvdwx(k,j)
2155      &             + dPOLdR2 * condor
2156
2157         gvdwc(k,i) = gvdwc(k,i)
2158      &             - dPOLdR2 * erhead_tail(k,2)
2159         gvdwc(k,j) = gvdwc(k,j)
2160      &             + dPOLdR2 * erhead_tail(k,2)
2161
2162        END DO
2163       RETURN
2164       END SUBROUTINE enq
2165
2166
2167 c!-------------------------------------------------------------------
2168
2169
2170       SUBROUTINE eqd(Ecl,Elj,Epol)
2171        IMPLICIT NONE
2172        INCLUDE 'DIMENSIONS'
2173        INCLUDE 'sizesclu.dat'
2174        INCLUDE 'COMMON.CALC'
2175        INCLUDE 'COMMON.CHAIN'
2176        INCLUDE 'COMMON.CONTROL'
2177        INCLUDE 'COMMON.DERIV'
2178        INCLUDE 'COMMON.EMP'
2179        INCLUDE 'COMMON.GEO'
2180        INCLUDE 'COMMON.INTERACT'
2181        INCLUDE 'COMMON.IOUNITS'
2182        INCLUDE 'COMMON.LOCAL'
2183        INCLUDE 'COMMON.NAMES'
2184        INCLUDE 'COMMON.VAR'
2185        double precision scalar, facd4, federmaus
2186        alphapol1 = alphapol(itypi,itypj)
2187        w1        = wqdip(1,itypi,itypj)
2188        w2        = wqdip(2,itypi,itypj)
2189        pis       = sig0head(itypi,itypj)
2190        eps_head   = epshead(itypi,itypj)
2191 c!-------------------------------------------------------------------
2192 c! R1 - distance between head of ith side chain and tail of jth sidechain
2193        R1 = 0.0d0
2194        DO k = 1, 3
2195 c! Calculate head-to-tail distances
2196         R1=R1+(ctail(k,2)-chead(k,1))**2
2197        END DO
2198 c! Pitagoras
2199        R1 = dsqrt(R1)
2200
2201 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2202 c!     &        +dhead(1,1,itypi,itypj))**2))
2203 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2204 c!     &        +dhead(2,1,itypi,itypj))**2))
2205
2206 c!-------------------------------------------------------------------
2207 c! ecl
2208        sparrow  = w1 * Qi * om1
2209        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2210        Ecl = sparrow / Rhead**2.0d0
2211      &     - hawk    / Rhead**4.0d0
2212 c!-------------------------------------------------------------------
2213 c! derivative of ecl is Gcl
2214 c! dF/dr part
2215        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2216      &           + 4.0d0 * hawk    / Rhead**5.0d0
2217 c! dF/dom1
2218        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2219 c! dF/dom2
2220        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2221 c--------------------------------------------------------------------
2222 c Polarization energy
2223 c Epol
2224        MomoFac1 = (1.0d0 - chi1 * sqom2)
2225        RR1  = R1 * R1 / MomoFac1
2226        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2227        fgb1 = sqrt( RR1 + a12sq * ee1)
2228        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2229 c!       epol = 0.0d0
2230 c!------------------------------------------------------------------
2231 c! derivative of Epol is Gpol...
2232        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2233      &          / (fgb1 ** 5.0d0)
2234        dFGBdR1 = ( (R1 / MomoFac1)
2235      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2236      &        / ( 2.0d0 * fgb1 )
2237        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2238      &          * (2.0d0 - 0.5d0 * ee1) )
2239      &          / (2.0d0 * fgb1)
2240        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2241 c!       dPOLdR1 = 0.0d0
2242        dPOLdOM1 = 0.0d0
2243        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2244 c!       dPOLdOM2 = 0.0d0
2245 c!-------------------------------------------------------------------
2246 c! Elj
2247        pom = (pis / Rhead)**6.0d0
2248        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2249 c! derivative of Elj is Glj
2250        dGLJdR = 4.0d0 * eps_head
2251      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2252      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2253 c!-------------------------------------------------------------------
2254 c! Return the results
2255        DO k = 1, 3
2256         erhead(k) = Rhead_distance(k)/Rhead
2257         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2258        END DO
2259
2260        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2261        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2262        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2263        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2264        facd1 = d1 * vbld_inv(i+nres)
2265        facd2 = d2 * vbld_inv(j+nres)
2266        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2267
2268        DO k = 1, 3
2269         hawk = (erhead_tail(k,1) +
2270      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2271
2272         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2273         gvdwx(k,i) = gvdwx(k,i)
2274      &             - dGCLdR * pom
2275      &             - dPOLdR1 * hawk
2276      &             - dGLJdR * pom
2277
2278         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2279         gvdwx(k,j) = gvdwx(k,j)
2280      &             + dGCLdR * pom
2281      &             + dPOLdR1 * (erhead_tail(k,1)
2282      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2283      &             + dGLJdR * pom
2284
2285
2286         gvdwc(k,i) = gvdwc(k,i)
2287      &             - dGCLdR * erhead(k)
2288      &             - dPOLdR1 * erhead_tail(k,1)
2289      &             - dGLJdR * erhead(k)
2290
2291         gvdwc(k,j) = gvdwc(k,j)
2292      &             + dGCLdR * erhead(k)
2293      &             + dPOLdR1 * erhead_tail(k,1)
2294      &             + dGLJdR * erhead(k)
2295
2296        END DO
2297        RETURN
2298       END SUBROUTINE eqd
2299
2300
2301 c!-------------------------------------------------------------------
2302
2303
2304       SUBROUTINE edq(Ecl,Elj,Epol)
2305        IMPLICIT NONE
2306        INCLUDE 'DIMENSIONS'
2307        INCLUDE 'sizesclu.dat'
2308        INCLUDE 'COMMON.CALC'
2309        INCLUDE 'COMMON.CHAIN'
2310        INCLUDE 'COMMON.CONTROL'
2311        INCLUDE 'COMMON.DERIV'
2312        INCLUDE 'COMMON.EMP'
2313        INCLUDE 'COMMON.GEO'
2314        INCLUDE 'COMMON.INTERACT'
2315        INCLUDE 'COMMON.IOUNITS'
2316        INCLUDE 'COMMON.LOCAL'
2317        INCLUDE 'COMMON.NAMES'
2318        INCLUDE 'COMMON.VAR'
2319        double precision scalar, facd3, adler
2320        alphapol2 = alphapol(itypj,itypi)
2321        w1        = wqdip(1,itypi,itypj)
2322        w2        = wqdip(2,itypi,itypj)
2323        pis       = sig0head(itypi,itypj)
2324        eps_head  = epshead(itypi,itypj)
2325 c!-------------------------------------------------------------------
2326 c! R2 - distance between head of jth side chain and tail of ith sidechain
2327        R2 = 0.0d0
2328        DO k = 1, 3
2329 c! Calculate head-to-tail distances
2330         R2=R2+(chead(k,2)-ctail(k,1))**2
2331        END DO
2332 c! Pitagoras
2333        R2 = dsqrt(R2)
2334
2335 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2336 c!     &        +dhead(1,1,itypi,itypj))**2))
2337 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2338 c!     &        +dhead(2,1,itypi,itypj))**2))
2339
2340
2341 c!-------------------------------------------------------------------
2342 c! ecl
2343        sparrow  = w1 * Qi * om1
2344        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2345        ECL = sparrow / Rhead**2.0d0
2346      &     - hawk    / Rhead**4.0d0
2347 c!-------------------------------------------------------------------
2348 c! derivative of ecl is Gcl
2349 c! dF/dr part
2350        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2351      &           + 4.0d0 * hawk    / Rhead**5.0d0
2352 c! dF/dom1
2353        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2354 c! dF/dom2
2355        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2356 c--------------------------------------------------------------------
2357 c Polarization energy
2358 c Epol
2359        MomoFac2 = (1.0d0 - chi2 * sqom1)
2360        RR2  = R2 * R2 / MomoFac2
2361        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2362        fgb2 = sqrt(RR2  + a12sq * ee2)
2363        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2364 c!       epol = 0.0d0
2365 c! derivative of Epol is Gpol...
2366        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2367      &          / (fgb2 ** 5.0d0)
2368        dFGBdR2 = ( (R2 / MomoFac2)
2369      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2370      &        / (2.0d0 * fgb2)
2371        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2372      &          * (2.0d0 - 0.5d0 * ee2) )
2373      &          / (2.0d0 * fgb2)
2374        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2375 c!       dPOLdR2 = 0.0d0
2376        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2377 c!       dPOLdOM1 = 0.0d0
2378        dPOLdOM2 = 0.0d0
2379 c!-------------------------------------------------------------------
2380 c! Elj
2381        pom = (pis / Rhead)**6.0d0
2382        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2383 c! derivative of Elj is Glj
2384        dGLJdR = 4.0d0 * eps_head
2385      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2386      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2387 c!-------------------------------------------------------------------
2388 c! Return the results
2389 c! (see comments in Eqq)
2390        DO k = 1, 3
2391         erhead(k) = Rhead_distance(k)/Rhead
2392         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2393        END DO
2394        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2395        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2396        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2397        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2398        facd1 = d1 * vbld_inv(i+nres)
2399        facd2 = d2 * vbld_inv(j+nres)
2400        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2401
2402        DO k = 1, 3
2403         condor = (erhead_tail(k,2)
2404      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2405
2406         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2407         gvdwx(k,i) = gvdwx(k,i)
2408      &             - dGCLdR * pom
2409      &             - dPOLdR2 * (erhead_tail(k,2)
2410      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2411      &             - dGLJdR * pom
2412
2413         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2414         gvdwx(k,j) = gvdwx(k,j)
2415      &             + dGCLdR * pom
2416      &             + dPOLdR2 * condor
2417      &             + dGLJdR * pom
2418
2419
2420         gvdwc(k,i) = gvdwc(k,i)
2421      &             - dGCLdR * erhead(k)
2422      &             - dPOLdR2 * erhead_tail(k,2)
2423      &             - dGLJdR * erhead(k)
2424
2425         gvdwc(k,j) = gvdwc(k,j)
2426      &             + dGCLdR * erhead(k)
2427      &             + dPOLdR2 * erhead_tail(k,2)
2428      &             + dGLJdR * erhead(k)
2429
2430        END DO
2431        RETURN
2432       END SUBROUTINE edq
2433
2434
2435 C--------------------------------------------------------------------
2436
2437
2438       SUBROUTINE edd(ECL)
2439        IMPLICIT NONE
2440        INCLUDE 'DIMENSIONS'
2441        INCLUDE 'sizesclu.dat'
2442        INCLUDE 'COMMON.CALC'
2443        INCLUDE 'COMMON.CHAIN'
2444        INCLUDE 'COMMON.CONTROL'
2445        INCLUDE 'COMMON.DERIV'
2446        INCLUDE 'COMMON.EMP'
2447        INCLUDE 'COMMON.GEO'
2448        INCLUDE 'COMMON.INTERACT'
2449        INCLUDE 'COMMON.IOUNITS'
2450        INCLUDE 'COMMON.LOCAL'
2451        INCLUDE 'COMMON.NAMES'
2452        INCLUDE 'COMMON.VAR'
2453        double precision scalar
2454 c!       csig = sigiso(itypi,itypj)
2455        w1 = wqdip(1,itypi,itypj)
2456        w2 = wqdip(2,itypi,itypj)
2457 c!-------------------------------------------------------------------
2458 c! ECL
2459        fac = (om12 - 3.0d0 * om1 * om2)
2460        c1 = (w1 / (Rhead**3.0d0)) * fac
2461        c2 = (w2 / Rhead ** 6.0d0)
2462      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2463        ECL = c1 - c2
2464 c!       write (*,*) "w1 = ", w1
2465 c!       write (*,*) "w2 = ", w2
2466 c!       write (*,*) "om1 = ", om1
2467 c!       write (*,*) "om2 = ", om2
2468 c!       write (*,*) "om12 = ", om12
2469 c!       write (*,*) "fac = ", fac
2470 c!       write (*,*) "c1 = ", c1
2471 c!       write (*,*) "c2 = ", c2
2472 c!       write (*,*) "Ecl = ", Ecl
2473 c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
2474 c!       write (*,*) "c2_2 = ",
2475 c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2476 c!-------------------------------------------------------------------
2477 c! dervative of ECL is GCL...
2478 c! dECL/dr
2479        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
2480        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)
2481      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
2482        dGCLdR = c1 - c2
2483 c! dECL/dom1
2484        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
2485        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2486      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
2487        dGCLdOM1 = c1 - c2
2488 c! dECL/dom2
2489        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
2490        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2491      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
2492        dGCLdOM2 = c1 - c2
2493 c! dECL/dom12
2494        c1 = w1 / (Rhead ** 3.0d0)
2495        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
2496        dGCLdOM12 = c1 - c2
2497 c!-------------------------------------------------------------------
2498 c! Return the results
2499 c! (see comments in Eqq)
2500        DO k= 1, 3
2501         erhead(k) = Rhead_distance(k)/Rhead
2502        END DO
2503        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2504        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2505        facd1 = d1 * vbld_inv(i+nres)
2506        facd2 = d2 * vbld_inv(j+nres)
2507        DO k = 1, 3
2508
2509         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2510         gvdwx(k,i) = gvdwx(k,i)
2511      &             - dGCLdR * pom
2512         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2513         gvdwx(k,j) = gvdwx(k,j)
2514      &             + dGCLdR * pom
2515
2516         gvdwc(k,i) = gvdwc(k,i)
2517      &             - dGCLdR * erhead(k)
2518         gvdwc(k,j) = gvdwc(k,j)
2519      &             + dGCLdR * erhead(k)
2520        END DO
2521        RETURN
2522       END SUBROUTINE edd
2523
2524
2525 c!-------------------------------------------------------------------
2526
2527
2528       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
2529        IMPLICIT NONE
2530 c! maxres
2531        INCLUDE 'DIMENSIONS'
2532        INCLUDE 'sizesclu.dat'
2533 c! itypi, itypj, i, j, k, l, chead,
2534        INCLUDE 'COMMON.CALC'
2535 c! c, nres, dc_norm
2536        INCLUDE 'COMMON.CHAIN'
2537 c! gradc, gradx
2538        INCLUDE 'COMMON.DERIV'
2539 c! electrostatic gradients-specific variables
2540        INCLUDE 'COMMON.EMP'
2541 c! wquad, dhead, alphiso, alphasur, rborn, epsintab
2542        INCLUDE 'COMMON.INTERACT'
2543 c! io for debug, disable it in final builds
2544        INCLUDE 'COMMON.IOUNITS'
2545 c!-------------------------------------------------------------------
2546 c! Variable Init
2547
2548 c! what amino acid is the aminoacid j'th?
2549        itypj = itype(j)
2550 c! 1/(Gas Constant * Thermostate temperature) = BetaTT
2551 c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
2552        BetaTT = 1.0d0 / (298 * 1.987d-3)
2553 c! Gay-berne var's
2554        sig0ij = sigma( itypi,itypj )
2555        chi1   = chi( itypi, itypj )
2556        chi2   = chi( itypj, itypi )
2557        chi12  = chi1 * chi2
2558        chip1  = chipp( itypi, itypj )
2559        chip2  = chipp( itypj, itypi )
2560        chip12 = chip1 * chip2
2561 c!       write (2,*) "elgrad types",itypi,itypj,
2562 c!     & " chi1",chi1," chi2",chi2," chi12",chi12,
2563 c!     &  " chip1",chip1," chip2",chip2," chip12",chip12
2564 c! not used by momo potential, but needed by sc_angular which is shared
2565 c! by all energy_potential subroutines
2566        alf1   = 0.0d0
2567        alf2   = 0.0d0
2568        alf12  = 0.0d0
2569 c! location, location, location
2570        xj  = c( 1, nres+j ) - xi
2571        yj  = c( 2, nres+j ) - yi
2572        zj  = c( 3, nres+j ) - zi
2573        dxj = dc_norm( 1, nres+j )
2574        dyj = dc_norm( 2, nres+j )
2575        dzj = dc_norm( 3, nres+j )
2576 c! distance from center of chain(?) to polar/charged head
2577 c!       write (*,*) "istate = ", 1
2578 c!       write (*,*) "ii = ", 1
2579 c!       write (*,*) "jj = ", 1
2580        d1 = dhead(1, 1, itypi, itypj)
2581        d2 = dhead(2, 1, itypi, itypj)
2582 c! ai*aj from Fgb
2583        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
2584 c!       a12sq = a12sq * a12sq
2585 c! charge of amino acid itypi is...
2586        Qi  = icharge(itypi)
2587        Qj  = icharge(itypj)
2588        Qij = Qi * Qj
2589 c! chis1,2,12
2590        chis1 = chis(itypi,itypj)
2591        chis2 = chis(itypj,itypi)
2592        chis12 = chis1 * chis2
2593        sig1 = sigmap1(itypi,itypj)
2594        sig2 = sigmap2(itypi,itypj)
2595 c!       write (*,*) "sig1 = ", sig1
2596 c!       write (*,*) "sig2 = ", sig2
2597 c! alpha factors from Fcav/Gcav
2598        b1 = alphasur(1,itypi,itypj)
2599        b2 = alphasur(2,itypi,itypj)
2600        b3 = alphasur(3,itypi,itypj)
2601        b4 = alphasur(4,itypi,itypj)
2602 c! used to determine whether we want to do quadrupole calculations
2603        wqd = wquad(itypi, itypj)
2604 c! used by Fgb
2605        eps_in = epsintab(itypi,itypj)
2606        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
2607 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
2608 c!-------------------------------------------------------------------
2609 c! tail location and distance calculations
2610        Rtail = 0.0d0
2611        DO k = 1, 3
2612         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
2613         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
2614        END DO
2615 c! tail distances will be themselves usefull elswhere
2616 c1 (in Gcav, for example)
2617        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
2618        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
2619        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
2620        Rtail = dsqrt(
2621      &     (Rtail_distance(1)*Rtail_distance(1))
2622      &   + (Rtail_distance(2)*Rtail_distance(2))
2623      &   + (Rtail_distance(3)*Rtail_distance(3)))
2624 c!-------------------------------------------------------------------
2625 c! Calculate location and distance between polar heads
2626 c! distance between heads
2627 c! for each one of our three dimensional space...
2628        DO k = 1,3
2629 c! location of polar head is computed by taking hydrophobic centre
2630 c! and moving by a d1 * dc_norm vector
2631 c! see unres publications for very informative images
2632         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
2633         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
2634 c! distance
2635 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
2636 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
2637         Rhead_distance(k) = chead(k,2) - chead(k,1)
2638        END DO
2639 c! pitagoras (root of sum of squares)
2640        Rhead = dsqrt(
2641      &     (Rhead_distance(1)*Rhead_distance(1))
2642      &   + (Rhead_distance(2)*Rhead_distance(2))
2643      &   + (Rhead_distance(3)*Rhead_distance(3)))
2644 c!-------------------------------------------------------------------
2645 c! zero everything that should be zero'ed
2646        Egb = 0.0d0
2647        ECL = 0.0d0
2648        Elj = 0.0d0
2649        Equad = 0.0d0
2650        Epol = 0.0d0
2651        eheadtail = 0.0d0
2652        dGCLdOM1 = 0.0d0
2653        dGCLdOM2 = 0.0d0
2654        dGCLdOM12 = 0.0d0
2655        dPOLdOM1 = 0.0d0
2656        dPOLdOM2 = 0.0d0
2657        RETURN
2658       END SUBROUTINE elgrad_init
2659 c!-------------------------------------------------------------------
2660       subroutine sc_angular
2661 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2662 C om12. Called by ebp, egb, and egbv.
2663       implicit none
2664       include 'COMMON.CALC'
2665       include 'COMMON.IOUNITS'
2666       erij(1)=xj*rij
2667       erij(2)=yj*rij
2668       erij(3)=zj*rij
2669       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2670       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2671       om12=dxi*dxj+dyi*dyj+dzi*dzj
2672 c!      om1    = 0.0d0
2673 c!      om2    = 0.0d0
2674 c!      om12   = 0.0d0
2675       chiom12=chi12*om12
2676 C Calculate eps1(om12) and its derivative in om12
2677       faceps1=1.0D0-om12*chiom12
2678       faceps1_inv=1.0D0/faceps1
2679       eps1=dsqrt(faceps1_inv)
2680 c      write (2,*) "chi1",chi1," chi2",chi2," chi12",chi12
2681 c      write (2,*) "fsceps1",faceps1," faceps1_inv",faceps1_inv,
2682 c     & " eps1",eps1
2683 C Following variable is eps1*deps1/dom12
2684       eps1_om12=faceps1_inv*chiom12
2685 c diagnostics only
2686 c      faceps1_inv=om12
2687 c      eps1=om12
2688 c      eps1_om12=1.0d0
2689 c      write (iout,*) "om12",om12," eps1",eps1
2690 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2691 C and om12.
2692       om1om2=om1*om2
2693       chiom1=chi1*om1
2694       chiom2=chi2*om2
2695       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2696       sigsq=1.0D0-facsig*faceps1_inv
2697 c      write (2,*) "om1",om1," om2",om2," om1om2",om1om2,
2698 c     & " chiom1",chiom1,
2699 c     &  " chiom2",chiom2," facsig",facsig," sigsq",sigsq
2700       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2701       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2702       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2703 c diagnostics only
2704 c      sigsq=1.0d0
2705 c      sigsq_om1=0.0d0
2706 c      sigsq_om2=0.0d0
2707 c      sigsq_om12=0.0d0
2708 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2709 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2710 c     &    " eps1",eps1
2711 C Calculate eps2 and its derivatives in om1, om2, and om12.
2712       chipom1=chip1*om1
2713       chipom2=chip2*om2
2714       chipom12=chip12*om12
2715       facp=1.0D0-om12*chipom12
2716       facp_inv=1.0D0/facp
2717       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2718 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2719 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2720 C Following variable is the square root of eps2
2721       eps2rt=1.0D0-facp1*facp_inv
2722 C Following three variables are the derivatives of the square root of eps
2723 C in om1, om2, and om12.
2724       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2725       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2726       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2727 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2728 c! Note that THIS is 0 in emomo, so we should probably move it out of sc_angular
2729 c! Or frankly, we should restructurize the whole energy section
2730       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2731 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2732 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2733 c     &  " eps2rt_om12",eps2rt_om12
2734 C Calculate whole angle-dependent part of epsilon and contributions
2735 C to its derivatives
2736       return
2737       end
2738 C----------------------------------------------------------------------------
2739 C----------------------------------------------------------------------------
2740       subroutine sc_grad
2741       implicit real*8 (a-h,o-z)
2742       include 'DIMENSIONS'
2743       include 'sizesclu.dat'
2744       include 'COMMON.CHAIN'
2745       include 'COMMON.DERIV'
2746       include 'COMMON.CALC'
2747       double precision dcosom1(3),dcosom2(3)
2748       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2749       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2750       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2751      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2752       do k=1,3
2753         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2754         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2755       enddo
2756       do k=1,3
2757         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2758       enddo
2759       do k=1,3
2760         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2761      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2762      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2763         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2764      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2765      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2766       enddo
2767 C
2768 C Calculate the components of the gradient in DC and X
2769 C
2770       do k=i,j-1
2771         do l=1,3
2772           gvdwc(l,k)=gvdwc(l,k)+gg(l)
2773         enddo
2774       enddo
2775       return
2776       end
2777 c------------------------------------------------------------------------------
2778       subroutine vec_and_deriv
2779       implicit real*8 (a-h,o-z)
2780       include 'DIMENSIONS'
2781       include 'sizesclu.dat'
2782       include 'COMMON.IOUNITS'
2783       include 'COMMON.GEO'
2784       include 'COMMON.VAR'
2785       include 'COMMON.LOCAL'
2786       include 'COMMON.CHAIN'
2787       include 'COMMON.VECTORS'
2788       include 'COMMON.DERIV'
2789       include 'COMMON.INTERACT'
2790       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2791 C Compute the local reference systems. For reference system (i), the
2792 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2793 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2794       do i=1,nres-1
2795 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
2796           if (i.eq.nres-1) then
2797 C Case of the last full residue
2798 C Compute the Z-axis
2799             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2800             costh=dcos(pi-theta(nres))
2801             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2802             do k=1,3
2803               uz(k,i)=fac*uz(k,i)
2804             enddo
2805             if (calc_grad) then
2806 C Compute the derivatives of uz
2807             uzder(1,1,1)= 0.0d0
2808             uzder(2,1,1)=-dc_norm(3,i-1)
2809             uzder(3,1,1)= dc_norm(2,i-1)
2810             uzder(1,2,1)= dc_norm(3,i-1)
2811             uzder(2,2,1)= 0.0d0
2812             uzder(3,2,1)=-dc_norm(1,i-1)
2813             uzder(1,3,1)=-dc_norm(2,i-1)
2814             uzder(2,3,1)= dc_norm(1,i-1)
2815             uzder(3,3,1)= 0.0d0
2816             uzder(1,1,2)= 0.0d0
2817             uzder(2,1,2)= dc_norm(3,i)
2818             uzder(3,1,2)=-dc_norm(2,i)
2819             uzder(1,2,2)=-dc_norm(3,i)
2820             uzder(2,2,2)= 0.0d0
2821             uzder(3,2,2)= dc_norm(1,i)
2822             uzder(1,3,2)= dc_norm(2,i)
2823             uzder(2,3,2)=-dc_norm(1,i)
2824             uzder(3,3,2)= 0.0d0
2825             endif
2826 C Compute the Y-axis
2827             facy=fac
2828             do k=1,3
2829               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2830             enddo
2831             if (calc_grad) then
2832 C Compute the derivatives of uy
2833             do j=1,3
2834               do k=1,3
2835                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2836      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2837                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2838               enddo
2839               uyder(j,j,1)=uyder(j,j,1)-costh
2840               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2841             enddo
2842             do j=1,2
2843               do k=1,3
2844                 do l=1,3
2845                   uygrad(l,k,j,i)=uyder(l,k,j)
2846                   uzgrad(l,k,j,i)=uzder(l,k,j)
2847                 enddo
2848               enddo
2849             enddo
2850             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2851             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2852             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2853             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2854             endif
2855           else
2856 C Other residues
2857 C Compute the Z-axis
2858             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2859             costh=dcos(pi-theta(i+2))
2860             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2861             do k=1,3
2862               uz(k,i)=fac*uz(k,i)
2863             enddo
2864             if (calc_grad) then
2865 C Compute the derivatives of uz
2866             uzder(1,1,1)= 0.0d0
2867             uzder(2,1,1)=-dc_norm(3,i+1)
2868             uzder(3,1,1)= dc_norm(2,i+1)
2869             uzder(1,2,1)= dc_norm(3,i+1)
2870             uzder(2,2,1)= 0.0d0
2871             uzder(3,2,1)=-dc_norm(1,i+1)
2872             uzder(1,3,1)=-dc_norm(2,i+1)
2873             uzder(2,3,1)= dc_norm(1,i+1)
2874             uzder(3,3,1)= 0.0d0
2875             uzder(1,1,2)= 0.0d0
2876             uzder(2,1,2)= dc_norm(3,i)
2877             uzder(3,1,2)=-dc_norm(2,i)
2878             uzder(1,2,2)=-dc_norm(3,i)
2879             uzder(2,2,2)= 0.0d0
2880             uzder(3,2,2)= dc_norm(1,i)
2881             uzder(1,3,2)= dc_norm(2,i)
2882             uzder(2,3,2)=-dc_norm(1,i)
2883             uzder(3,3,2)= 0.0d0
2884             endif
2885 C Compute the Y-axis
2886             facy=fac
2887             do k=1,3
2888               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2889             enddo
2890             if (calc_grad) then
2891 C Compute the derivatives of uy
2892             do j=1,3
2893               do k=1,3
2894                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2895      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2896                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2897               enddo
2898               uyder(j,j,1)=uyder(j,j,1)-costh
2899               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2900             enddo
2901             do j=1,2
2902               do k=1,3
2903                 do l=1,3
2904                   uygrad(l,k,j,i)=uyder(l,k,j)
2905                   uzgrad(l,k,j,i)=uzder(l,k,j)
2906                 enddo
2907               enddo
2908             enddo
2909             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2910             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2911             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2912             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2913           endif
2914           endif
2915       enddo
2916       if (calc_grad) then
2917       do i=1,nres-1
2918         vbld_inv_temp(1)=vbld_inv(i+1)
2919         if (i.lt.nres-1) then
2920           vbld_inv_temp(2)=vbld_inv(i+2)
2921         else
2922           vbld_inv_temp(2)=vbld_inv(i)
2923         endif
2924         do j=1,2
2925           do k=1,3
2926             do l=1,3
2927               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2928               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2929             enddo
2930           enddo
2931         enddo
2932       enddo
2933       endif
2934       return
2935       end
2936 C-----------------------------------------------------------------------------
2937       subroutine vec_and_deriv_test
2938       implicit real*8 (a-h,o-z)
2939       include 'DIMENSIONS'
2940       include 'sizesclu.dat'
2941       include 'COMMON.IOUNITS'
2942       include 'COMMON.GEO'
2943       include 'COMMON.VAR'
2944       include 'COMMON.LOCAL'
2945       include 'COMMON.CHAIN'
2946       include 'COMMON.VECTORS'
2947       dimension uyder(3,3,2),uzder(3,3,2)
2948 C Compute the local reference systems. For reference system (i), the
2949 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2950 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2951       do i=1,nres-1
2952           if (i.eq.nres-1) then
2953 C Case of the last full residue
2954 C Compute the Z-axis
2955             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2956             costh=dcos(pi-theta(nres))
2957             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2958 c            write (iout,*) 'fac',fac,
2959 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
2960             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
2961             do k=1,3
2962               uz(k,i)=fac*uz(k,i)
2963             enddo
2964 C Compute the derivatives of uz
2965             uzder(1,1,1)= 0.0d0
2966             uzder(2,1,1)=-dc_norm(3,i-1)
2967             uzder(3,1,1)= dc_norm(2,i-1)
2968             uzder(1,2,1)= dc_norm(3,i-1)
2969             uzder(2,2,1)= 0.0d0
2970             uzder(3,2,1)=-dc_norm(1,i-1)
2971             uzder(1,3,1)=-dc_norm(2,i-1)
2972             uzder(2,3,1)= dc_norm(1,i-1)
2973             uzder(3,3,1)= 0.0d0
2974             uzder(1,1,2)= 0.0d0
2975             uzder(2,1,2)= dc_norm(3,i)
2976             uzder(3,1,2)=-dc_norm(2,i)
2977             uzder(1,2,2)=-dc_norm(3,i)
2978             uzder(2,2,2)= 0.0d0
2979             uzder(3,2,2)= dc_norm(1,i)
2980             uzder(1,3,2)= dc_norm(2,i)
2981             uzder(2,3,2)=-dc_norm(1,i)
2982             uzder(3,3,2)= 0.0d0
2983 C Compute the Y-axis
2984             do k=1,3
2985               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2986             enddo
2987             facy=fac
2988             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
2989      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
2990      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
2991             do k=1,3
2992 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2993               uy(k,i)=
2994 c     &        facy*(
2995      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
2996      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
2997 c     &        )
2998             enddo
2999 c            write (iout,*) 'facy',facy,
3000 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3001             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3002             do k=1,3
3003               uy(k,i)=facy*uy(k,i)
3004             enddo
3005 C Compute the derivatives of uy
3006             do j=1,3
3007               do k=1,3
3008                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
3009      &                        -dc_norm(k,i)*dc_norm(j,i-1)
3010                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3011               enddo
3012 c              uyder(j,j,1)=uyder(j,j,1)-costh
3013 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
3014               uyder(j,j,1)=uyder(j,j,1)
3015      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
3016               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
3017      &          +uyder(j,j,2)
3018             enddo
3019             do j=1,2
3020               do k=1,3
3021                 do l=1,3
3022                   uygrad(l,k,j,i)=uyder(l,k,j)
3023                   uzgrad(l,k,j,i)=uzder(l,k,j)
3024                 enddo
3025               enddo
3026             enddo
3027             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3028             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3029             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3030             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3031           else
3032 C Other residues
3033 C Compute the Z-axis
3034             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
3035             costh=dcos(pi-theta(i+2))
3036             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3037             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3038             do k=1,3
3039               uz(k,i)=fac*uz(k,i)
3040             enddo
3041 C Compute the derivatives of uz
3042             uzder(1,1,1)= 0.0d0
3043             uzder(2,1,1)=-dc_norm(3,i+1)
3044             uzder(3,1,1)= dc_norm(2,i+1)
3045             uzder(1,2,1)= dc_norm(3,i+1)
3046             uzder(2,2,1)= 0.0d0
3047             uzder(3,2,1)=-dc_norm(1,i+1)
3048             uzder(1,3,1)=-dc_norm(2,i+1)
3049             uzder(2,3,1)= dc_norm(1,i+1)
3050             uzder(3,3,1)= 0.0d0
3051             uzder(1,1,2)= 0.0d0
3052             uzder(2,1,2)= dc_norm(3,i)
3053             uzder(3,1,2)=-dc_norm(2,i)
3054             uzder(1,2,2)=-dc_norm(3,i)
3055             uzder(2,2,2)= 0.0d0
3056             uzder(3,2,2)= dc_norm(1,i)
3057             uzder(1,3,2)= dc_norm(2,i)
3058             uzder(2,3,2)=-dc_norm(1,i)
3059             uzder(3,3,2)= 0.0d0
3060 C Compute the Y-axis
3061             facy=fac
3062             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
3063      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
3064      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
3065             do k=1,3
3066 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3067               uy(k,i)=
3068 c     &        facy*(
3069      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
3070      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
3071 c     &        )
3072             enddo
3073 c            write (iout,*) 'facy',facy,
3074 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3075             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3076             do k=1,3
3077               uy(k,i)=facy*uy(k,i)
3078             enddo
3079 C Compute the derivatives of uy
3080             do j=1,3
3081               do k=1,3
3082                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
3083      &                        -dc_norm(k,i)*dc_norm(j,i+1)
3084                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3085               enddo
3086 c              uyder(j,j,1)=uyder(j,j,1)-costh
3087 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
3088               uyder(j,j,1)=uyder(j,j,1)
3089      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
3090               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
3091      &          +uyder(j,j,2)
3092             enddo
3093             do j=1,2
3094               do k=1,3
3095                 do l=1,3
3096                   uygrad(l,k,j,i)=uyder(l,k,j)
3097                   uzgrad(l,k,j,i)=uzder(l,k,j)
3098                 enddo
3099               enddo
3100             enddo
3101             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3102             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3103             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3104             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3105           endif
3106       enddo
3107       do i=1,nres-1
3108         do j=1,2
3109           do k=1,3
3110             do l=1,3
3111               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
3112               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
3113             enddo
3114           enddo
3115         enddo
3116       enddo
3117       return
3118       end
3119 C-----------------------------------------------------------------------------
3120       subroutine check_vecgrad
3121       implicit real*8 (a-h,o-z)
3122       include 'DIMENSIONS'
3123       include 'sizesclu.dat'
3124       include 'COMMON.IOUNITS'
3125       include 'COMMON.GEO'
3126       include 'COMMON.VAR'
3127       include 'COMMON.LOCAL'
3128       include 'COMMON.CHAIN'
3129       include 'COMMON.VECTORS'
3130       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
3131       dimension uyt(3,maxres),uzt(3,maxres)
3132       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
3133       double precision delta /1.0d-7/
3134       call vec_and_deriv
3135 cd      do i=1,nres
3136 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
3137 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
3138 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
3139 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
3140 cd     &     (dc_norm(if90,i),if90=1,3)
3141 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
3142 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
3143 cd          write(iout,'(a)')
3144 cd      enddo
3145       do i=1,nres
3146         do j=1,2
3147           do k=1,3
3148             do l=1,3
3149               uygradt(l,k,j,i)=uygrad(l,k,j,i)
3150               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
3151             enddo
3152           enddo
3153         enddo
3154       enddo
3155       call vec_and_deriv
3156       do i=1,nres
3157         do j=1,3
3158           uyt(j,i)=uy(j,i)
3159           uzt(j,i)=uz(j,i)
3160         enddo
3161       enddo
3162       do i=1,nres
3163 cd        write (iout,*) 'i=',i
3164         do k=1,3
3165           erij(k)=dc_norm(k,i)
3166         enddo
3167         do j=1,3
3168           do k=1,3
3169             dc_norm(k,i)=erij(k)
3170           enddo
3171           dc_norm(j,i)=dc_norm(j,i)+delta
3172 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
3173 c          do k=1,3
3174 c            dc_norm(k,i)=dc_norm(k,i)/fac
3175 c          enddo
3176 c          write (iout,*) (dc_norm(k,i),k=1,3)
3177 c          write (iout,*) (erij(k),k=1,3)
3178           call vec_and_deriv
3179           do k=1,3
3180             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
3181             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
3182             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
3183             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
3184           enddo
3185 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3186 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
3187 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
3188         enddo
3189         do k=1,3
3190           dc_norm(k,i)=erij(k)
3191         enddo
3192 cd        do k=1,3
3193 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3194 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
3195 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
3196 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3197 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
3198 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
3199 cd          write (iout,'(a)')
3200 cd        enddo
3201       enddo
3202       return
3203       end
3204 C--------------------------------------------------------------------------
3205       subroutine set_matrices
3206       implicit real*8 (a-h,o-z)
3207       include 'DIMENSIONS'
3208       include 'sizesclu.dat'
3209       include 'COMMON.IOUNITS'
3210       include 'COMMON.GEO'
3211       include 'COMMON.VAR'
3212       include 'COMMON.LOCAL'
3213       include 'COMMON.CHAIN'
3214       include 'COMMON.DERIV'
3215       include 'COMMON.INTERACT'
3216       include 'COMMON.CONTACTS'
3217       include 'COMMON.TORSION'
3218       include 'COMMON.VECTORS'
3219       include 'COMMON.FFIELD'
3220       double precision auxvec(2),auxmat(2,2)
3221 C
3222 C Compute the virtual-bond-torsional-angle dependent quantities needed
3223 C to calculate the el-loc multibody terms of various order.
3224 C
3225       do i=3,nres+1
3226         if (i .lt. nres+1) then
3227           sin1=dsin(phi(i))
3228           cos1=dcos(phi(i))
3229           sintab(i-2)=sin1
3230           costab(i-2)=cos1
3231           obrot(1,i-2)=cos1
3232           obrot(2,i-2)=sin1
3233           sin2=dsin(2*phi(i))
3234           cos2=dcos(2*phi(i))
3235           sintab2(i-2)=sin2
3236           costab2(i-2)=cos2
3237           obrot2(1,i-2)=cos2
3238           obrot2(2,i-2)=sin2
3239           Ug(1,1,i-2)=-cos1
3240           Ug(1,2,i-2)=-sin1
3241           Ug(2,1,i-2)=-sin1
3242           Ug(2,2,i-2)= cos1
3243           Ug2(1,1,i-2)=-cos2
3244           Ug2(1,2,i-2)=-sin2
3245           Ug2(2,1,i-2)=-sin2
3246           Ug2(2,2,i-2)= cos2
3247         else
3248           costab(i-2)=1.0d0
3249           sintab(i-2)=0.0d0
3250           obrot(1,i-2)=1.0d0
3251           obrot(2,i-2)=0.0d0
3252           obrot2(1,i-2)=0.0d0
3253           obrot2(2,i-2)=0.0d0
3254           Ug(1,1,i-2)=1.0d0
3255           Ug(1,2,i-2)=0.0d0
3256           Ug(2,1,i-2)=0.0d0
3257           Ug(2,2,i-2)=1.0d0
3258           Ug2(1,1,i-2)=0.0d0
3259           Ug2(1,2,i-2)=0.0d0
3260           Ug2(2,1,i-2)=0.0d0
3261           Ug2(2,2,i-2)=0.0d0
3262         endif
3263         if (i .gt. 3 .and. i .lt. nres+1) then
3264           obrot_der(1,i-2)=-sin1
3265           obrot_der(2,i-2)= cos1
3266           Ugder(1,1,i-2)= sin1
3267           Ugder(1,2,i-2)=-cos1
3268           Ugder(2,1,i-2)=-cos1
3269           Ugder(2,2,i-2)=-sin1
3270           dwacos2=cos2+cos2
3271           dwasin2=sin2+sin2
3272           obrot2_der(1,i-2)=-dwasin2
3273           obrot2_der(2,i-2)= dwacos2
3274           Ug2der(1,1,i-2)= dwasin2
3275           Ug2der(1,2,i-2)=-dwacos2
3276           Ug2der(2,1,i-2)=-dwacos2
3277           Ug2der(2,2,i-2)=-dwasin2
3278         else
3279           obrot_der(1,i-2)=0.0d0
3280           obrot_der(2,i-2)=0.0d0
3281           Ugder(1,1,i-2)=0.0d0
3282           Ugder(1,2,i-2)=0.0d0
3283           Ugder(2,1,i-2)=0.0d0
3284           Ugder(2,2,i-2)=0.0d0
3285           obrot2_der(1,i-2)=0.0d0
3286           obrot2_der(2,i-2)=0.0d0
3287           Ug2der(1,1,i-2)=0.0d0
3288           Ug2der(1,2,i-2)=0.0d0
3289           Ug2der(2,1,i-2)=0.0d0
3290           Ug2der(2,2,i-2)=0.0d0
3291         endif
3292         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3293           iti = itortyp(itype(i-2))
3294         else
3295           iti=ntortyp+1
3296         endif
3297         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3298           iti1 = itortyp(itype(i-1))
3299         else
3300           iti1=ntortyp+1
3301         endif
3302 cd        write (iout,*) '*******i',i,' iti1',iti
3303 cd        write (iout,*) 'b1',b1(:,iti)
3304 cd        write (iout,*) 'b2',b2(:,iti)
3305 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3306         if (i .gt. iatel_s+2) then
3307           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
3308           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
3309           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3310           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3311           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3312           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3313           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3314         else
3315           do k=1,2
3316             Ub2(k,i-2)=0.0d0
3317             Ctobr(k,i-2)=0.0d0
3318             Dtobr2(k,i-2)=0.0d0
3319             do l=1,2
3320               EUg(l,k,i-2)=0.0d0
3321               CUg(l,k,i-2)=0.0d0
3322               DUg(l,k,i-2)=0.0d0
3323               DtUg2(l,k,i-2)=0.0d0
3324             enddo
3325           enddo
3326         endif
3327         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
3328         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
3329         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3330         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3331         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3332         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3333         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3334         do k=1,2
3335           muder(k,i-2)=Ub2der(k,i-2)
3336         enddo
3337         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3338           iti1 = itortyp(itype(i-1))
3339         else
3340           iti1=ntortyp+1
3341         endif
3342         do k=1,2
3343           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
3344         enddo
3345 C Vectors and matrices dependent on a single virtual-bond dihedral.
3346         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
3347         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3348         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3349         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3350         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3351         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3352         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3353         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3354         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3355 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
3356 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
3357       enddo
3358 C Matrices dependent on two consecutive virtual-bond dihedrals.
3359 C The order of matrices is from left to right.
3360       do i=2,nres-1
3361         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3362         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3363         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3364         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3365         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3366         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3367         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3368         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3369       enddo
3370 cd      do i=1,nres
3371 cd        iti = itortyp(itype(i))
3372 cd        write (iout,*) i
3373 cd        do j=1,2
3374 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3375 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3376 cd        enddo
3377 cd      enddo
3378       return
3379       end
3380 C--------------------------------------------------------------------------
3381       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3382 C
3383 C This subroutine calculates the average interaction energy and its gradient
3384 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3385 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3386 C The potential depends both on the distance of peptide-group centers and on
3387 C the orientation of the CA-CA virtual bonds.
3388 C
3389       implicit real*8 (a-h,o-z)
3390       include 'DIMENSIONS'
3391       include 'sizesclu.dat'
3392       include 'COMMON.CONTROL'
3393       include 'COMMON.IOUNITS'
3394       include 'COMMON.GEO'
3395       include 'COMMON.VAR'
3396       include 'COMMON.LOCAL'
3397       include 'COMMON.CHAIN'
3398       include 'COMMON.DERIV'
3399       include 'COMMON.INTERACT'
3400       include 'COMMON.CONTACTS'
3401       include 'COMMON.TORSION'
3402       include 'COMMON.VECTORS'
3403       include 'COMMON.FFIELD'
3404       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3405      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3406       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3407      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3408       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
3409 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3410       double precision scal_el /0.5d0/
3411 C 12/13/98
3412 C 13-go grudnia roku pamietnego...
3413       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3414      &                   0.0d0,1.0d0,0.0d0,
3415      &                   0.0d0,0.0d0,1.0d0/
3416 cd      write(iout,*) 'In EELEC'
3417 cd      do i=1,nloctyp
3418 cd        write(iout,*) 'Type',i
3419 cd        write(iout,*) 'B1',B1(:,i)
3420 cd        write(iout,*) 'B2',B2(:,i)
3421 cd        write(iout,*) 'CC',CC(:,:,i)
3422 cd        write(iout,*) 'DD',DD(:,:,i)
3423 cd        write(iout,*) 'EE',EE(:,:,i)
3424 cd      enddo
3425 cd      call check_vecgrad
3426 cd      stop
3427       if (icheckgrad.eq.1) then
3428         do i=1,nres-1
3429           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3430           do k=1,3
3431             dc_norm(k,i)=dc(k,i)*fac
3432           enddo
3433 c          write (iout,*) 'i',i,' fac',fac
3434         enddo
3435       endif
3436       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3437      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3438      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3439 cd      if (wel_loc.gt.0.0d0) then
3440         if (icheckgrad.eq.1) then
3441         call vec_and_deriv_test
3442         else
3443         call vec_and_deriv
3444         endif
3445         call set_matrices
3446       endif
3447 cd      do i=1,nres-1
3448 cd        write (iout,*) 'i=',i
3449 cd        do k=1,3
3450 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3451 cd        enddo
3452 cd        do k=1,3
3453 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3454 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3455 cd        enddo
3456 cd      enddo
3457       num_conti_hb=0
3458       ees=0.0D0
3459       evdw1=0.0D0
3460       eel_loc=0.0d0
3461       eello_turn3=0.0d0
3462       eello_turn4=0.0d0
3463       ind=0
3464       do i=1,nres
3465         num_cont_hb(i)=0
3466       enddo
3467 cd      print '(a)','Enter EELEC'
3468 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3469       do i=1,nres
3470         gel_loc_loc(i)=0.0d0
3471         gcorr_loc(i)=0.0d0
3472       enddo
3473       do i=iatel_s,iatel_e
3474         if (itel(i).eq.0) goto 1215
3475         dxi=dc(1,i)
3476         dyi=dc(2,i)
3477         dzi=dc(3,i)
3478         dx_normi=dc_norm(1,i)
3479         dy_normi=dc_norm(2,i)
3480         dz_normi=dc_norm(3,i)
3481         xmedi=c(1,i)+0.5d0*dxi
3482         ymedi=c(2,i)+0.5d0*dyi
3483         zmedi=c(3,i)+0.5d0*dzi
3484         num_conti=0
3485 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3486         do j=ielstart(i),ielend(i)
3487           if (itel(j).eq.0) goto 1216
3488           ind=ind+1
3489           iteli=itel(i)
3490           itelj=itel(j)
3491           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3492           aaa=app(iteli,itelj)
3493           bbb=bpp(iteli,itelj)
3494 C Diagnostics only!!!
3495 c         aaa=0.0D0
3496 c         bbb=0.0D0
3497 c         ael6i=0.0D0
3498 c         ael3i=0.0D0
3499 C End diagnostics
3500           ael6i=ael6(iteli,itelj)
3501           ael3i=ael3(iteli,itelj)
3502           dxj=dc(1,j)
3503           dyj=dc(2,j)
3504           dzj=dc(3,j)
3505           dx_normj=dc_norm(1,j)
3506           dy_normj=dc_norm(2,j)
3507           dz_normj=dc_norm(3,j)
3508           xj=c(1,j)+0.5D0*dxj-xmedi
3509           yj=c(2,j)+0.5D0*dyj-ymedi
3510           zj=c(3,j)+0.5D0*dzj-zmedi
3511           rij=xj*xj+yj*yj+zj*zj
3512           rrmij=1.0D0/rij
3513           rij=dsqrt(rij)
3514           rmij=1.0D0/rij
3515           r3ij=rrmij*rmij
3516           r6ij=r3ij*r3ij
3517           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3518           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3519           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3520           fac=cosa-3.0D0*cosb*cosg
3521           ev1=aaa*r6ij*r6ij
3522 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3523           if (j.eq.i+2) ev1=scal_el*ev1
3524           ev2=bbb*r6ij
3525           fac3=ael6i*r6ij
3526           fac4=ael3i*r3ij
3527           evdwij=ev1+ev2
3528           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3529           el2=fac4*fac
3530           eesij=el1+el2
3531 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
3532 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3533           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3534           ees=ees+eesij
3535           evdw1=evdw1+evdwij
3536 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3537 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3538 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3539 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3540 C
3541 C Calculate contributions to the Cartesian gradient.
3542 C
3543 #ifdef SPLITELE
3544           facvdw=-6*rrmij*(ev1+evdwij)
3545           facel=-3*rrmij*(el1+eesij)
3546           fac1=fac
3547           erij(1)=xj*rmij
3548           erij(2)=yj*rmij
3549           erij(3)=zj*rmij
3550           if (calc_grad) then
3551 *
3552 * Radial derivatives. First process both termini of the fragment (i,j)
3553 *
3554           ggg(1)=facel*xj
3555           ggg(2)=facel*yj
3556           ggg(3)=facel*zj
3557           do k=1,3
3558             ghalf=0.5D0*ggg(k)
3559             gelc(k,i)=gelc(k,i)+ghalf
3560             gelc(k,j)=gelc(k,j)+ghalf
3561           enddo
3562 *
3563 * Loop over residues i+1 thru j-1.
3564 *
3565           do k=i+1,j-1
3566             do l=1,3
3567               gelc(l,k)=gelc(l,k)+ggg(l)
3568             enddo
3569           enddo
3570           ggg(1)=facvdw*xj
3571           ggg(2)=facvdw*yj
3572           ggg(3)=facvdw*zj
3573           do k=1,3
3574             ghalf=0.5D0*ggg(k)
3575             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3576             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3577           enddo
3578 *
3579 * Loop over residues i+1 thru j-1.
3580 *
3581           do k=i+1,j-1
3582             do l=1,3
3583               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3584             enddo
3585           enddo
3586 #else
3587           facvdw=ev1+evdwij
3588           facel=el1+eesij
3589           fac1=fac
3590           fac=-3*rrmij*(facvdw+facvdw+facel)
3591           erij(1)=xj*rmij
3592           erij(2)=yj*rmij
3593           erij(3)=zj*rmij
3594           if (calc_grad) then
3595 *
3596 * Radial derivatives. First process both termini of the fragment (i,j)
3597 *
3598           ggg(1)=fac*xj
3599           ggg(2)=fac*yj
3600           ggg(3)=fac*zj
3601           do k=1,3
3602             ghalf=0.5D0*ggg(k)
3603             gelc(k,i)=gelc(k,i)+ghalf
3604             gelc(k,j)=gelc(k,j)+ghalf
3605           enddo
3606 *
3607 * Loop over residues i+1 thru j-1.
3608 *
3609           do k=i+1,j-1
3610             do l=1,3
3611               gelc(l,k)=gelc(l,k)+ggg(l)
3612             enddo
3613           enddo
3614 #endif
3615 *
3616 * Angular part
3617 *
3618           ecosa=2.0D0*fac3*fac1+fac4
3619           fac4=-3.0D0*fac4
3620           fac3=-6.0D0*fac3
3621           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3622           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3623           do k=1,3
3624             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3625             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3626           enddo
3627 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3628 cd   &          (dcosg(k),k=1,3)
3629           do k=1,3
3630             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3631           enddo
3632           do k=1,3
3633             ghalf=0.5D0*ggg(k)
3634             gelc(k,i)=gelc(k,i)+ghalf
3635      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3636      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3637             gelc(k,j)=gelc(k,j)+ghalf
3638      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3639      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3640           enddo
3641           do k=i+1,j-1
3642             do l=1,3
3643               gelc(l,k)=gelc(l,k)+ggg(l)
3644             enddo
3645           enddo
3646           endif
3647
3648           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3649      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3650      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3651 C
3652 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3653 C   energy of a peptide unit is assumed in the form of a second-order
3654 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3655 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3656 C   are computed for EVERY pair of non-contiguous peptide groups.
3657 C
3658           if (j.lt.nres-1) then
3659             j1=j+1
3660             j2=j-1
3661           else
3662             j1=j-1
3663             j2=j-2
3664           endif
3665           kkk=0
3666           do k=1,2
3667             do l=1,2
3668               kkk=kkk+1
3669               muij(kkk)=mu(k,i)*mu(l,j)
3670             enddo
3671           enddo
3672 cd         write (iout,*) 'EELEC: i',i,' j',j
3673 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3674 cd          write(iout,*) 'muij',muij
3675           ury=scalar(uy(1,i),erij)
3676           urz=scalar(uz(1,i),erij)
3677           vry=scalar(uy(1,j),erij)
3678           vrz=scalar(uz(1,j),erij)
3679           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3680           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3681           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3682           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3683 C For diagnostics only
3684 cd          a22=1.0d0
3685 cd          a23=1.0d0
3686 cd          a32=1.0d0
3687 cd          a33=1.0d0
3688           fac=dsqrt(-ael6i)*r3ij
3689 cd          write (2,*) 'fac=',fac
3690 C For diagnostics only
3691 cd          fac=1.0d0
3692           a22=a22*fac
3693           a23=a23*fac
3694           a32=a32*fac
3695           a33=a33*fac
3696 cd          write (iout,'(4i5,4f10.5)')
3697 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3698 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3699 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
3700 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
3701 cd          write (iout,'(4f10.5)')
3702 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3703 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3704 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3705 cd           write (iout,'(2i3,9f10.5/)') i,j,
3706 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3707           if (calc_grad) then
3708 C Derivatives of the elements of A in virtual-bond vectors
3709           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3710 cd          do k=1,3
3711 cd            do l=1,3
3712 cd              erder(k,l)=0.0d0
3713 cd            enddo
3714 cd          enddo
3715           do k=1,3
3716             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3717             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3718             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3719             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3720             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3721             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3722             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3723             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3724             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3725             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3726             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3727             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3728           enddo
3729 cd          do k=1,3
3730 cd            do l=1,3
3731 cd              uryg(k,l)=0.0d0
3732 cd              urzg(k,l)=0.0d0
3733 cd              vryg(k,l)=0.0d0
3734 cd              vrzg(k,l)=0.0d0
3735 cd            enddo
3736 cd          enddo
3737 C Compute radial contributions to the gradient
3738           facr=-3.0d0*rrmij
3739           a22der=a22*facr
3740           a23der=a23*facr
3741           a32der=a32*facr
3742           a33der=a33*facr
3743 cd          a22der=0.0d0
3744 cd          a23der=0.0d0
3745 cd          a32der=0.0d0
3746 cd          a33der=0.0d0
3747           agg(1,1)=a22der*xj
3748           agg(2,1)=a22der*yj
3749           agg(3,1)=a22der*zj
3750           agg(1,2)=a23der*xj
3751           agg(2,2)=a23der*yj
3752           agg(3,2)=a23der*zj
3753           agg(1,3)=a32der*xj
3754           agg(2,3)=a32der*yj
3755           agg(3,3)=a32der*zj
3756           agg(1,4)=a33der*xj
3757           agg(2,4)=a33der*yj
3758           agg(3,4)=a33der*zj
3759 C Add the contributions coming from er
3760           fac3=-3.0d0*fac
3761           do k=1,3
3762             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3763             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3764             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3765             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3766           enddo
3767           do k=1,3
3768 C Derivatives in DC(i)
3769             ghalf1=0.5d0*agg(k,1)
3770             ghalf2=0.5d0*agg(k,2)
3771             ghalf3=0.5d0*agg(k,3)
3772             ghalf4=0.5d0*agg(k,4)
3773             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3774      &      -3.0d0*uryg(k,2)*vry)+ghalf1
3775             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3776      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
3777             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3778      &      -3.0d0*urzg(k,2)*vry)+ghalf3
3779             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3780      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
3781 C Derivatives in DC(i+1)
3782             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3783      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
3784             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3785      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
3786             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3787      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
3788             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3789      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
3790 C Derivatives in DC(j)
3791             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3792      &      -3.0d0*vryg(k,2)*ury)+ghalf1
3793             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3794      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
3795             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3796      &      -3.0d0*vryg(k,2)*urz)+ghalf3
3797             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3798      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
3799 C Derivatives in DC(j+1) or DC(nres-1)
3800             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3801      &      -3.0d0*vryg(k,3)*ury)
3802             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3803      &      -3.0d0*vrzg(k,3)*ury)
3804             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3805      &      -3.0d0*vryg(k,3)*urz)
3806             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3807      &      -3.0d0*vrzg(k,3)*urz)
3808 cd            aggi(k,1)=ghalf1
3809 cd            aggi(k,2)=ghalf2
3810 cd            aggi(k,3)=ghalf3
3811 cd            aggi(k,4)=ghalf4
3812 C Derivatives in DC(i+1)
3813 cd            aggi1(k,1)=agg(k,1)
3814 cd            aggi1(k,2)=agg(k,2)
3815 cd            aggi1(k,3)=agg(k,3)
3816 cd            aggi1(k,4)=agg(k,4)
3817 C Derivatives in DC(j)
3818 cd            aggj(k,1)=ghalf1
3819 cd            aggj(k,2)=ghalf2
3820 cd            aggj(k,3)=ghalf3
3821 cd            aggj(k,4)=ghalf4
3822 C Derivatives in DC(j+1)
3823 cd            aggj1(k,1)=0.0d0
3824 cd            aggj1(k,2)=0.0d0
3825 cd            aggj1(k,3)=0.0d0
3826 cd            aggj1(k,4)=0.0d0
3827             if (j.eq.nres-1 .and. i.lt.j-2) then
3828               do l=1,4
3829                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
3830 cd                aggj1(k,l)=agg(k,l)
3831               enddo
3832             endif
3833           enddo
3834           endif
3835 c          goto 11111
3836 C Check the loc-el terms by numerical integration
3837           acipa(1,1)=a22
3838           acipa(1,2)=a23
3839           acipa(2,1)=a32
3840           acipa(2,2)=a33
3841           a22=-a22
3842           a23=-a23
3843           do l=1,2
3844             do k=1,3
3845               agg(k,l)=-agg(k,l)
3846               aggi(k,l)=-aggi(k,l)
3847               aggi1(k,l)=-aggi1(k,l)
3848               aggj(k,l)=-aggj(k,l)
3849               aggj1(k,l)=-aggj1(k,l)
3850             enddo
3851           enddo
3852           if (j.lt.nres-1) then
3853             a22=-a22
3854             a32=-a32
3855             do l=1,3,2
3856               do k=1,3
3857                 agg(k,l)=-agg(k,l)
3858                 aggi(k,l)=-aggi(k,l)
3859                 aggi1(k,l)=-aggi1(k,l)
3860                 aggj(k,l)=-aggj(k,l)
3861                 aggj1(k,l)=-aggj1(k,l)
3862               enddo
3863             enddo
3864           else
3865             a22=-a22
3866             a23=-a23
3867             a32=-a32
3868             a33=-a33
3869             do l=1,4
3870               do k=1,3
3871                 agg(k,l)=-agg(k,l)
3872                 aggi(k,l)=-aggi(k,l)
3873                 aggi1(k,l)=-aggi1(k,l)
3874                 aggj(k,l)=-aggj(k,l)
3875                 aggj1(k,l)=-aggj1(k,l)
3876               enddo
3877             enddo
3878           endif
3879           ENDIF ! WCORR
3880 11111     continue
3881           IF (wel_loc.gt.0.0d0) THEN
3882 C Contribution to the local-electrostatic energy coming from the i-j pair
3883           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3884      &     +a33*muij(4)
3885 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3886 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3887           eel_loc=eel_loc+eel_loc_ij
3888 C Partial derivatives in virtual-bond dihedral angles gamma
3889           if (calc_grad) then
3890           if (i.gt.1)
3891      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3892      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3893      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3894           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3895      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3896      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3897 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
3898 cd          write(iout,*) 'agg  ',agg
3899 cd          write(iout,*) 'aggi ',aggi
3900 cd          write(iout,*) 'aggi1',aggi1
3901 cd          write(iout,*) 'aggj ',aggj
3902 cd          write(iout,*) 'aggj1',aggj1
3903
3904 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3905           do l=1,3
3906             ggg(l)=agg(l,1)*muij(1)+
3907      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3908           enddo
3909           do k=i+2,j2
3910             do l=1,3
3911               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3912             enddo
3913           enddo
3914 C Remaining derivatives of eello
3915           do l=1,3
3916             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3917      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3918             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3919      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3920             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3921      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3922             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3923      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3924           enddo
3925           endif
3926           ENDIF
3927           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3928 C Contributions from turns
3929             a_temp(1,1)=a22
3930             a_temp(1,2)=a23
3931             a_temp(2,1)=a32
3932             a_temp(2,2)=a33
3933             call eturn34(i,j,eello_turn3,eello_turn4)
3934           endif
3935 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3936           if (j.gt.i+1 .and. num_conti.le.maxconts) then
3937 C
3938 C Calculate the contact function. The ith column of the array JCONT will
3939 C contain the numbers of atoms that make contacts with the atom I (of numbers
3940 C greater than I). The arrays FACONT and GACONT will contain the values of
3941 C the contact function and its derivative.
3942 c           r0ij=1.02D0*rpp(iteli,itelj)
3943 c           r0ij=1.11D0*rpp(iteli,itelj)
3944             r0ij=2.20D0*rpp(iteli,itelj)
3945 c           r0ij=1.55D0*rpp(iteli,itelj)
3946             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3947             if (fcont.gt.0.0D0) then
3948               num_conti=num_conti+1
3949               if (num_conti.gt.maxconts) then
3950                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3951      &                         ' will skip next contacts for this conf.'
3952               else
3953                 jcont_hb(num_conti,i)=j
3954                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3955      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3956 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3957 C  terms.
3958                 d_cont(num_conti,i)=rij
3959 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3960 C     --- Electrostatic-interaction matrix ---
3961                 a_chuj(1,1,num_conti,i)=a22
3962                 a_chuj(1,2,num_conti,i)=a23
3963                 a_chuj(2,1,num_conti,i)=a32
3964                 a_chuj(2,2,num_conti,i)=a33
3965 C     --- Gradient of rij
3966                 do kkk=1,3
3967                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3968                 enddo
3969 c             if (i.eq.1) then
3970 c                a_chuj(1,1,num_conti,i)=-0.61d0
3971 c                a_chuj(1,2,num_conti,i)= 0.4d0
3972 c                a_chuj(2,1,num_conti,i)= 0.65d0
3973 c                a_chuj(2,2,num_conti,i)= 0.50d0
3974 c             else if (i.eq.2) then
3975 c                a_chuj(1,1,num_conti,i)= 0.0d0
3976 c                a_chuj(1,2,num_conti,i)= 0.0d0
3977 c                a_chuj(2,1,num_conti,i)= 0.0d0
3978 c                a_chuj(2,2,num_conti,i)= 0.0d0
3979 c             endif
3980 C     --- and its gradients
3981 cd                write (iout,*) 'i',i,' j',j
3982 cd                do kkk=1,3
3983 cd                write (iout,*) 'iii 1 kkk',kkk
3984 cd                write (iout,*) agg(kkk,:)
3985 cd                enddo
3986 cd                do kkk=1,3
3987 cd                write (iout,*) 'iii 2 kkk',kkk
3988 cd                write (iout,*) aggi(kkk,:)
3989 cd                enddo
3990 cd                do kkk=1,3
3991 cd                write (iout,*) 'iii 3 kkk',kkk
3992 cd                write (iout,*) aggi1(kkk,:)
3993 cd                enddo
3994 cd                do kkk=1,3
3995 cd                write (iout,*) 'iii 4 kkk',kkk
3996 cd                write (iout,*) aggj(kkk,:)
3997 cd                enddo
3998 cd                do kkk=1,3
3999 cd                write (iout,*) 'iii 5 kkk',kkk
4000 cd                write (iout,*) aggj1(kkk,:)
4001 cd                enddo
4002                 kkll=0
4003                 do k=1,2
4004                   do l=1,2
4005                     kkll=kkll+1
4006                     do m=1,3
4007                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4008                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4009                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4010                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4011                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4012 c                      do mm=1,5
4013 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
4014 c                      enddo
4015                     enddo
4016                   enddo
4017                 enddo
4018                 ENDIF
4019                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4020 C Calculate contact energies
4021                 cosa4=4.0D0*cosa
4022                 wij=cosa-3.0D0*cosb*cosg
4023                 cosbg1=cosb+cosg
4024                 cosbg2=cosb-cosg
4025 c               fac3=dsqrt(-ael6i)/r0ij**3
4026                 fac3=dsqrt(-ael6i)*r3ij
4027                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4028                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4029 c               ees0mij=0.0D0
4030                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4031                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4032 C Diagnostics. Comment out or remove after debugging!
4033 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4034 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4035 c               ees0m(num_conti,i)=0.0D0
4036 C End diagnostics.
4037 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4038 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4039                 facont_hb(num_conti,i)=fcont
4040                 if (calc_grad) then
4041 C Angular derivatives of the contact function
4042                 ees0pij1=fac3/ees0pij
4043                 ees0mij1=fac3/ees0mij
4044                 fac3p=-3.0D0*fac3*rrmij
4045                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4046                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4047 c               ees0mij1=0.0D0
4048                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4049                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4050                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4051                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4052                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4053                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4054                 ecosap=ecosa1+ecosa2
4055                 ecosbp=ecosb1+ecosb2
4056                 ecosgp=ecosg1+ecosg2
4057                 ecosam=ecosa1-ecosa2
4058                 ecosbm=ecosb1-ecosb2
4059                 ecosgm=ecosg1-ecosg2
4060 C Diagnostics
4061 c               ecosap=ecosa1
4062 c               ecosbp=ecosb1
4063 c               ecosgp=ecosg1
4064 c               ecosam=0.0D0
4065 c               ecosbm=0.0D0
4066 c               ecosgm=0.0D0
4067 C End diagnostics
4068                 fprimcont=fprimcont/rij
4069 cd              facont_hb(num_conti,i)=1.0D0
4070 C Following line is for diagnostics.
4071 cd              fprimcont=0.0D0
4072                 do k=1,3
4073                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4074                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4075                 enddo
4076                 do k=1,3
4077                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4078                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4079                 enddo
4080                 gggp(1)=gggp(1)+ees0pijp*xj
4081                 gggp(2)=gggp(2)+ees0pijp*yj
4082                 gggp(3)=gggp(3)+ees0pijp*zj
4083                 gggm(1)=gggm(1)+ees0mijp*xj
4084                 gggm(2)=gggm(2)+ees0mijp*yj
4085                 gggm(3)=gggm(3)+ees0mijp*zj
4086 C Derivatives due to the contact function
4087                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4088                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4089                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4090                 do k=1,3
4091                   ghalfp=0.5D0*gggp(k)
4092                   ghalfm=0.5D0*gggm(k)
4093                   gacontp_hb1(k,num_conti,i)=ghalfp
4094      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4095      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4096                   gacontp_hb2(k,num_conti,i)=ghalfp
4097      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4098      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4099                   gacontp_hb3(k,num_conti,i)=gggp(k)
4100                   gacontm_hb1(k,num_conti,i)=ghalfm
4101      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4102      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4103                   gacontm_hb2(k,num_conti,i)=ghalfm
4104      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4105      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4106                   gacontm_hb3(k,num_conti,i)=gggm(k)
4107                 enddo
4108                 endif
4109 C Diagnostics. Comment out or remove after debugging!
4110 cdiag           do k=1,3
4111 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4112 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4113 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4114 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4115 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4116 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4117 cdiag           enddo
4118               ENDIF ! wcorr
4119               endif  ! num_conti.le.maxconts
4120             endif  ! fcont.gt.0
4121           endif    ! j.gt.i+1
4122  1216     continue
4123         enddo ! j
4124         num_cont_hb(i)=num_conti
4125  1215   continue
4126       enddo   ! i
4127 cd      do i=1,nres
4128 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
4129 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
4130 cd      enddo
4131 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
4132 ccc      eel_loc=eel_loc+eello_turn3
4133       return
4134       end
4135 C-----------------------------------------------------------------------------
4136       subroutine eturn34(i,j,eello_turn3,eello_turn4)
4137 C Third- and fourth-order contributions from turns
4138       implicit real*8 (a-h,o-z)
4139       include 'DIMENSIONS'
4140       include 'sizesclu.dat'
4141       include 'COMMON.IOUNITS'
4142       include 'COMMON.GEO'
4143       include 'COMMON.VAR'
4144       include 'COMMON.LOCAL'
4145       include 'COMMON.CHAIN'
4146       include 'COMMON.DERIV'
4147       include 'COMMON.INTERACT'
4148       include 'COMMON.CONTACTS'
4149       include 'COMMON.TORSION'
4150       include 'COMMON.VECTORS'
4151       include 'COMMON.FFIELD'
4152       dimension ggg(3)
4153       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4154      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4155      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
4156       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4157      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
4158       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
4159       if (j.eq.i+2) then
4160 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4161 C
4162 C               Third-order contributions
4163 C
4164 C                 (i+2)o----(i+3)
4165 C                      | |
4166 C                      | |
4167 C                 (i+1)o----i
4168 C
4169 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4170 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4171         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4172         call transpose2(auxmat(1,1),auxmat1(1,1))
4173         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4174         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4175 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4176 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4177 cd     &    ' eello_turn3_num',4*eello_turn3_num
4178         if (calc_grad) then
4179 C Derivatives in gamma(i)
4180         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4181         call transpose2(auxmat2(1,1),pizda(1,1))
4182         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
4183         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4184 C Derivatives in gamma(i+1)
4185         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4186         call transpose2(auxmat2(1,1),pizda(1,1))
4187         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
4188         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4189      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4190 C Cartesian derivatives
4191         do l=1,3
4192           a_temp(1,1)=aggi(l,1)
4193           a_temp(1,2)=aggi(l,2)
4194           a_temp(2,1)=aggi(l,3)
4195           a_temp(2,2)=aggi(l,4)
4196           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4197           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4198      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4199           a_temp(1,1)=aggi1(l,1)
4200           a_temp(1,2)=aggi1(l,2)
4201           a_temp(2,1)=aggi1(l,3)
4202           a_temp(2,2)=aggi1(l,4)
4203           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4204           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4205      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4206           a_temp(1,1)=aggj(l,1)
4207           a_temp(1,2)=aggj(l,2)
4208           a_temp(2,1)=aggj(l,3)
4209           a_temp(2,2)=aggj(l,4)
4210           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4211           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4212      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4213           a_temp(1,1)=aggj1(l,1)
4214           a_temp(1,2)=aggj1(l,2)
4215           a_temp(2,1)=aggj1(l,3)
4216           a_temp(2,2)=aggj1(l,4)
4217           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4218           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4219      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4220         enddo
4221         endif
4222       else if (j.eq.i+3) then
4223 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4224 C
4225 C               Fourth-order contributions
4226 C
4227 C                 (i+3)o----(i+4)
4228 C                     /  |
4229 C               (i+2)o   |
4230 C                     \  |
4231 C                 (i+1)o----i
4232 C
4233 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4234 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4235         iti1=itortyp(itype(i+1))
4236         iti2=itortyp(itype(i+2))
4237         iti3=itortyp(itype(i+3))
4238         call transpose2(EUg(1,1,i+1),e1t(1,1))
4239         call transpose2(Eug(1,1,i+2),e2t(1,1))
4240         call transpose2(Eug(1,1,i+3),e3t(1,1))
4241         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4242         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4243         s1=scalar2(b1(1,iti2),auxvec(1))
4244         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4245         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4246         s2=scalar2(b1(1,iti1),auxvec(1))
4247         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4248         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4249         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4250         eello_turn4=eello_turn4-(s1+s2+s3)
4251 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4252 cd     &    ' eello_turn4_num',8*eello_turn4_num
4253 C Derivatives in gamma(i)
4254         if (calc_grad) then
4255         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4256         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4257         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4258         s1=scalar2(b1(1,iti2),auxvec(1))
4259         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4260         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4261         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4262 C Derivatives in gamma(i+1)
4263         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4264         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4265         s2=scalar2(b1(1,iti1),auxvec(1))
4266         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4267         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4268         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4269         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4270 C Derivatives in gamma(i+2)
4271         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4272         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4273         s1=scalar2(b1(1,iti2),auxvec(1))
4274         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4275         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4276         s2=scalar2(b1(1,iti1),auxvec(1))
4277         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
4278         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4279         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4280         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4281 C Cartesian derivatives
4282 C Derivatives of this turn contributions in DC(i+2)
4283         if (j.lt.nres-1) then
4284           do l=1,3
4285             a_temp(1,1)=agg(l,1)
4286             a_temp(1,2)=agg(l,2)
4287             a_temp(2,1)=agg(l,3)
4288             a_temp(2,2)=agg(l,4)
4289             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4290             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4291             s1=scalar2(b1(1,iti2),auxvec(1))
4292             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4293             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4294             s2=scalar2(b1(1,iti1),auxvec(1))
4295             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4296             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4297             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4298             ggg(l)=-(s1+s2+s3)
4299             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4300           enddo
4301         endif
4302 C Remaining derivatives of this turn contribution
4303         do l=1,3
4304           a_temp(1,1)=aggi(l,1)
4305           a_temp(1,2)=aggi(l,2)
4306           a_temp(2,1)=aggi(l,3)
4307           a_temp(2,2)=aggi(l,4)
4308           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4309           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4310           s1=scalar2(b1(1,iti2),auxvec(1))
4311           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4312           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4313           s2=scalar2(b1(1,iti1),auxvec(1))
4314           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4315           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4316           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4317           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4318           a_temp(1,1)=aggi1(l,1)
4319           a_temp(1,2)=aggi1(l,2)
4320           a_temp(2,1)=aggi1(l,3)
4321           a_temp(2,2)=aggi1(l,4)
4322           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4323           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4324           s1=scalar2(b1(1,iti2),auxvec(1))
4325           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4326           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4327           s2=scalar2(b1(1,iti1),auxvec(1))
4328           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4329           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4330           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4331           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4332           a_temp(1,1)=aggj(l,1)
4333           a_temp(1,2)=aggj(l,2)
4334           a_temp(2,1)=aggj(l,3)
4335           a_temp(2,2)=aggj(l,4)
4336           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4337           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4338           s1=scalar2(b1(1,iti2),auxvec(1))
4339           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4340           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4341           s2=scalar2(b1(1,iti1),auxvec(1))
4342           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4343           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4344           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4345           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4346           a_temp(1,1)=aggj1(l,1)
4347           a_temp(1,2)=aggj1(l,2)
4348           a_temp(2,1)=aggj1(l,3)
4349           a_temp(2,2)=aggj1(l,4)
4350           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4351           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4352           s1=scalar2(b1(1,iti2),auxvec(1))
4353           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4354           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4355           s2=scalar2(b1(1,iti1),auxvec(1))
4356           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4357           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4358           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4359           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4360         enddo
4361         endif
4362       endif
4363       return
4364       end
4365 C-----------------------------------------------------------------------------
4366       subroutine vecpr(u,v,w)
4367       implicit real*8(a-h,o-z)
4368       dimension u(3),v(3),w(3)
4369       w(1)=u(2)*v(3)-u(3)*v(2)
4370       w(2)=-u(1)*v(3)+u(3)*v(1)
4371       w(3)=u(1)*v(2)-u(2)*v(1)
4372       return
4373       end
4374 C-----------------------------------------------------------------------------
4375       subroutine unormderiv(u,ugrad,unorm,ungrad)
4376 C This subroutine computes the derivatives of a normalized vector u, given
4377 C the derivatives computed without normalization conditions, ugrad. Returns
4378 C ungrad.
4379       implicit none
4380       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4381       double precision vec(3)
4382       double precision scalar
4383       integer i,j
4384 c      write (2,*) 'ugrad',ugrad
4385 c      write (2,*) 'u',u
4386       do i=1,3
4387         vec(i)=scalar(ugrad(1,i),u(1))
4388       enddo
4389 c      write (2,*) 'vec',vec
4390       do i=1,3
4391         do j=1,3
4392           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4393         enddo
4394       enddo
4395 c      write (2,*) 'ungrad',ungrad
4396       return
4397       end
4398 C-----------------------------------------------------------------------------
4399       subroutine escp(evdw2,evdw2_14)
4400 C
4401 C This subroutine calculates the excluded-volume interaction energy between
4402 C peptide-group centers and side chains and its gradient in virtual-bond and
4403 C side-chain vectors.
4404 C
4405       implicit real*8 (a-h,o-z)
4406       include 'DIMENSIONS'
4407       include 'sizesclu.dat'
4408       include 'COMMON.GEO'
4409       include 'COMMON.VAR'
4410       include 'COMMON.LOCAL'
4411       include 'COMMON.CHAIN'
4412       include 'COMMON.DERIV'
4413       include 'COMMON.INTERACT'
4414       include 'COMMON.FFIELD'
4415       include 'COMMON.IOUNITS'
4416       dimension ggg(3)
4417       evdw2=0.0D0
4418       evdw2_14=0.0d0
4419 cd    print '(a)','Enter ESCP'
4420 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
4421 c     &  ' scal14',scal14
4422       do i=iatscp_s,iatscp_e
4423         iteli=itel(i)
4424 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
4425 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
4426         if (iteli.eq.0) goto 1225
4427         xi=0.5D0*(c(1,i)+c(1,i+1))
4428         yi=0.5D0*(c(2,i)+c(2,i+1))
4429         zi=0.5D0*(c(3,i)+c(3,i+1))
4430
4431         do iint=1,nscp_gr(i)
4432
4433         do j=iscpstart(i,iint),iscpend(i,iint)
4434           itypj=itype(j)
4435 C Uncomment following three lines for SC-p interactions
4436 c         xj=c(1,nres+j)-xi
4437 c         yj=c(2,nres+j)-yi
4438 c         zj=c(3,nres+j)-zi
4439 C Uncomment following three lines for Ca-p interactions
4440           xj=c(1,j)-xi
4441           yj=c(2,j)-yi
4442           zj=c(3,j)-zi
4443           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4444           fac=rrij**expon2
4445           e1=fac*fac*aad(itypj,iteli)
4446           e2=fac*bad(itypj,iteli)
4447           if (iabs(j-i) .le. 2) then
4448             e1=scal14*e1
4449             e2=scal14*e2
4450             evdw2_14=evdw2_14+e1+e2
4451           endif
4452           evdwij=e1+e2
4453 c          write (iout,*) i,j,evdwij
4454           evdw2=evdw2+evdwij
4455           if (calc_grad) then
4456 C
4457 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4458 C
4459           fac=-(evdwij+e1)*rrij
4460           ggg(1)=xj*fac
4461           ggg(2)=yj*fac
4462           ggg(3)=zj*fac
4463           if (j.lt.i) then
4464 cd          write (iout,*) 'j<i'
4465 C Uncomment following three lines for SC-p interactions
4466 c           do k=1,3
4467 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4468 c           enddo
4469           else
4470 cd          write (iout,*) 'j>i'
4471             do k=1,3
4472               ggg(k)=-ggg(k)
4473 C Uncomment following line for SC-p interactions
4474 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4475             enddo
4476           endif
4477           do k=1,3
4478             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4479           enddo
4480           kstart=min0(i+1,j)
4481           kend=max0(i-1,j-1)
4482 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4483 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4484           do k=kstart,kend
4485             do l=1,3
4486               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4487             enddo
4488           enddo
4489           endif
4490         enddo
4491         enddo ! iint
4492  1225   continue
4493       enddo ! i
4494       do i=1,nct
4495         do j=1,3
4496           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4497           gradx_scp(j,i)=expon*gradx_scp(j,i)
4498         enddo
4499       enddo
4500 C******************************************************************************
4501 C
4502 C                              N O T E !!!
4503 C
4504 C To save time the factor EXPON has been extracted from ALL components
4505 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4506 C use!
4507 C
4508 C******************************************************************************
4509       return
4510       end
4511 C--------------------------------------------------------------------------
4512       subroutine edis(ehpb)
4513 C
4514 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4515 C
4516       implicit real*8 (a-h,o-z)
4517       include 'DIMENSIONS'
4518       include 'COMMON.SBRIDGE'
4519       include 'COMMON.CHAIN'
4520       include 'COMMON.DERIV'
4521       include 'COMMON.VAR'
4522       include 'COMMON.INTERACT'
4523       include 'COMMON.IOUNITS'
4524       dimension ggg(3)
4525       ehpb=0.0D0
4526 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4527 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4528       if (link_end.eq.0) return
4529       do i=link_start,link_end
4530 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4531 C CA-CA distance used in regularization of structure.
4532         ii=ihpb(i)
4533         jj=jhpb(i)
4534 C iii and jjj point to the residues for which the distance is assigned.
4535         if (ii.gt.nres) then
4536           iii=ii-nres
4537           jjj=jj-nres
4538         else
4539           iii=ii
4540           jjj=jj
4541         endif
4542 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4543 c     &    dhpb(i),dhpb1(i),forcon(i)
4544 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4545 C    distance and angle dependent SS bond potential.
4546         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4547           call ssbond_ene(iii,jjj,eij)
4548           ehpb=ehpb+2*eij
4549 cd          write (iout,*) "eij",eij
4550         else if (ii.gt.nres .and. jj.gt.nres) then
4551 c Restraints from contact prediction
4552           dd=dist(ii,jj)
4553           if (dhpb1(i).gt.0.0d0) then
4554             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4555             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4556 c            write (iout,*) "beta nmr",
4557 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4558           else
4559             dd=dist(ii,jj)
4560             rdis=dd-dhpb(i)
4561 C Get the force constant corresponding to this distance.
4562             waga=forcon(i)
4563 C Calculate the contribution to energy.
4564             ehpb=ehpb+waga*rdis*rdis
4565 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4566 C
4567 C Evaluate gradient.
4568 C
4569             fac=waga*rdis/dd
4570           endif
4571           do j=1,3
4572             ggg(j)=fac*(c(j,jj)-c(j,ii))
4573           enddo
4574           do j=1,3
4575             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4576             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4577           enddo
4578           do k=1,3
4579             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4580             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4581           enddo
4582         else
4583 C Calculate the distance between the two points and its difference from the
4584 C target distance.
4585           dd=dist(ii,jj)
4586           if (dhpb1(i).gt.0.0d0) then
4587             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4588             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4589 c            write (iout,*) "alph nmr",
4590 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4591           else
4592             rdis=dd-dhpb(i)
4593 C Get the force constant corresponding to this distance.
4594             waga=forcon(i)
4595 C Calculate the contribution to energy.
4596             ehpb=ehpb+waga*rdis*rdis
4597 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4598 C
4599 C Evaluate gradient.
4600 C
4601             fac=waga*rdis/dd
4602           endif
4603 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4604 cd   &   ' waga=',waga,' fac=',fac
4605             do j=1,3
4606               ggg(j)=fac*(c(j,jj)-c(j,ii))
4607             enddo
4608 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4609 C If this is a SC-SC distance, we need to calculate the contributions to the
4610 C Cartesian gradient in the SC vectors (ghpbx).
4611           if (iii.lt.ii) then
4612           do j=1,3
4613             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4614             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4615           enddo
4616           endif
4617           do k=1,3
4618             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4619             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4620           enddo
4621         endif
4622       enddo
4623       ehpb=0.5D0*ehpb
4624       return
4625       end
4626 C--------------------------------------------------------------------------
4627       subroutine ssbond_ene(i,j,eij)
4628 C
4629 C Calculate the distance and angle dependent SS-bond potential energy
4630 C using a free-energy function derived based on RHF/6-31G** ab initio
4631 C calculations of diethyl disulfide.
4632 C
4633 C A. Liwo and U. Kozlowska, 11/24/03
4634 C
4635       implicit real*8 (a-h,o-z)
4636       include 'DIMENSIONS'
4637       include 'sizesclu.dat'
4638       include 'COMMON.SBRIDGE'
4639       include 'COMMON.CHAIN'
4640       include 'COMMON.DERIV'
4641       include 'COMMON.LOCAL'
4642       include 'COMMON.INTERACT'
4643       include 'COMMON.VAR'
4644       include 'COMMON.IOUNITS'
4645       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4646       itypi=itype(i)
4647       xi=c(1,nres+i)
4648       yi=c(2,nres+i)
4649       zi=c(3,nres+i)
4650       dxi=dc_norm(1,nres+i)
4651       dyi=dc_norm(2,nres+i)
4652       dzi=dc_norm(3,nres+i)
4653       dsci_inv=dsc_inv(itypi)
4654       itypj=itype(j)
4655       dscj_inv=dsc_inv(itypj)
4656       xj=c(1,nres+j)-xi
4657       yj=c(2,nres+j)-yi
4658       zj=c(3,nres+j)-zi
4659       dxj=dc_norm(1,nres+j)
4660       dyj=dc_norm(2,nres+j)
4661       dzj=dc_norm(3,nres+j)
4662       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4663       rij=dsqrt(rrij)
4664       erij(1)=xj*rij
4665       erij(2)=yj*rij
4666       erij(3)=zj*rij
4667       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4668       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4669       om12=dxi*dxj+dyi*dyj+dzi*dzj
4670       do k=1,3
4671         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4672         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4673       enddo
4674       rij=1.0d0/rij
4675       deltad=rij-d0cm
4676       deltat1=1.0d0-om1
4677       deltat2=1.0d0+om2
4678       deltat12=om2-om1+2.0d0
4679       cosphi=om12-om1*om2
4680       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4681      &  +akct*deltad*deltat12
4682      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4683 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4684 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4685 c     &  " deltat12",deltat12," eij",eij
4686       ed=2*akcm*deltad+akct*deltat12
4687       pom1=akct*deltad
4688       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4689       eom1=-2*akth*deltat1-pom1-om2*pom2
4690       eom2= 2*akth*deltat2+pom1-om1*pom2
4691       eom12=pom2
4692       do k=1,3
4693         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4694       enddo
4695       do k=1,3
4696         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4697      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4698         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4699      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4700       enddo
4701 C
4702 C Calculate the components of the gradient in DC and X
4703 C
4704       do k=i,j-1
4705         do l=1,3
4706           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4707         enddo
4708       enddo
4709       return
4710       end
4711 C--------------------------------------------------------------------------
4712       subroutine ebond(estr)
4713 c
4714 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4715 c
4716       implicit real*8 (a-h,o-z)
4717       include 'DIMENSIONS'
4718       include 'COMMON.LOCAL'
4719       include 'COMMON.GEO'
4720       include 'COMMON.INTERACT'
4721       include 'COMMON.DERIV'
4722       include 'COMMON.VAR'
4723       include 'COMMON.CHAIN'
4724       include 'COMMON.IOUNITS'
4725       include 'COMMON.NAMES'
4726       include 'COMMON.FFIELD'
4727       include 'COMMON.CONTROL'
4728       double precision u(3),ud(3)
4729       estr=0.0d0
4730       do i=nnt+1,nct
4731         diff = vbld(i)-vbldp0
4732 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4733         estr=estr+diff*diff
4734         do j=1,3
4735           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4736         enddo
4737       enddo
4738       estr=0.5d0*AKP*estr
4739 c
4740 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4741 c
4742       do i=nnt,nct
4743         iti=itype(i)
4744         if (iti.ne.10) then
4745           nbi=nbondterm(iti)
4746           if (nbi.eq.1) then
4747             diff=vbld(i+nres)-vbldsc0(1,iti)
4748 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4749 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4750             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4751             do j=1,3
4752               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4753             enddo
4754           else
4755             do j=1,nbi
4756               diff=vbld(i+nres)-vbldsc0(j,iti)
4757               ud(j)=aksc(j,iti)*diff
4758               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4759             enddo
4760             uprod=u(1)
4761             do j=2,nbi
4762               uprod=uprod*u(j)
4763             enddo
4764             usum=0.0d0
4765             usumsqder=0.0d0
4766             do j=1,nbi
4767               uprod1=1.0d0
4768               uprod2=1.0d0
4769               do k=1,nbi
4770                 if (k.ne.j) then
4771                   uprod1=uprod1*u(k)
4772                   uprod2=uprod2*u(k)*u(k)
4773                 endif
4774               enddo
4775               usum=usum+uprod1
4776               usumsqder=usumsqder+ud(j)*uprod2
4777             enddo
4778 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4779 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4780             estr=estr+uprod/usum
4781             do j=1,3
4782              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4783             enddo
4784           endif
4785         endif
4786       enddo
4787       return
4788       end
4789 #ifdef CRYST_THETA
4790 C--------------------------------------------------------------------------
4791       subroutine ebend(etheta)
4792 C
4793 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4794 C angles gamma and its derivatives in consecutive thetas and gammas.
4795 C
4796       implicit real*8 (a-h,o-z)
4797       include 'DIMENSIONS'
4798       include 'sizesclu.dat'
4799       include 'COMMON.LOCAL'
4800       include 'COMMON.GEO'
4801       include 'COMMON.INTERACT'
4802       include 'COMMON.DERIV'
4803       include 'COMMON.VAR'
4804       include 'COMMON.CHAIN'
4805       include 'COMMON.IOUNITS'
4806       include 'COMMON.NAMES'
4807       include 'COMMON.FFIELD'
4808       common /calcthet/ term1,term2,termm,diffak,ratak,
4809      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4810      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4811       double precision y(2),z(2)
4812       delta=0.02d0*pi
4813       time11=dexp(-2*time)
4814       time12=1.0d0
4815       etheta=0.0D0
4816 c      write (iout,*) "nres",nres
4817 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4818 c      write (iout,*) ithet_start,ithet_end
4819       do i=ithet_start,ithet_end
4820 C Zero the energy function and its derivative at 0 or pi.
4821         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4822         it=itype(i-1)
4823 c        if (i.gt.ithet_start .and.
4824 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
4825 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
4826 c          phii=phi(i)
4827 c          y(1)=dcos(phii)
4828 c          y(2)=dsin(phii)
4829 c        else
4830 c          y(1)=0.0D0
4831 c          y(2)=0.0D0
4832 c        endif
4833 c        if (i.lt.nres .and. itel(i).ne.0) then
4834 c          phii1=phi(i+1)
4835 c          z(1)=dcos(phii1)
4836 c          z(2)=dsin(phii1)
4837 c        else
4838 c          z(1)=0.0D0
4839 c          z(2)=0.0D0
4840 c        endif
4841         if (i.gt.3) then
4842 #ifdef OSF
4843           phii=phi(i)
4844           icrc=0
4845           call proc_proc(phii,icrc)
4846           if (icrc.eq.1) phii=150.0
4847 #else
4848           phii=phi(i)
4849 #endif
4850           y(1)=dcos(phii)
4851           y(2)=dsin(phii)
4852         else
4853           y(1)=0.0D0
4854           y(2)=0.0D0
4855         endif
4856         if (i.lt.nres) then
4857 #ifdef OSF
4858           phii1=phi(i+1)
4859           icrc=0
4860           call proc_proc(phii1,icrc)
4861           if (icrc.eq.1) phii1=150.0
4862           phii1=pinorm(phii1)
4863           z(1)=cos(phii1)
4864 #else
4865           phii1=phi(i+1)
4866           z(1)=dcos(phii1)
4867 #endif
4868           z(2)=dsin(phii1)
4869         else
4870           z(1)=0.0D0
4871           z(2)=0.0D0
4872         endif
4873 C Calculate the "mean" value of theta from the part of the distribution
4874 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4875 C In following comments this theta will be referred to as t_c.
4876         thet_pred_mean=0.0d0
4877         do k=1,2
4878           athetk=athet(k,it)
4879           bthetk=bthet(k,it)
4880           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4881         enddo
4882 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4883         dthett=thet_pred_mean*ssd
4884         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4885 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4886 C Derivatives of the "mean" values in gamma1 and gamma2.
4887         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4888         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4889         if (theta(i).gt.pi-delta) then
4890           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4891      &         E_tc0)
4892           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4893           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4894           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4895      &        E_theta)
4896           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4897      &        E_tc)
4898         else if (theta(i).lt.delta) then
4899           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4900           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4901           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4902      &        E_theta)
4903           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4904           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4905      &        E_tc)
4906         else
4907           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4908      &        E_theta,E_tc)
4909         endif
4910         etheta=etheta+ethetai
4911 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4912 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4913         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4914         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4915         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4916  1215   continue
4917       enddo
4918 C Ufff.... We've done all this!!!
4919       return
4920       end
4921 C---------------------------------------------------------------------------
4922       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4923      &     E_tc)
4924       implicit real*8 (a-h,o-z)
4925       include 'DIMENSIONS'
4926       include 'COMMON.LOCAL'
4927       include 'COMMON.IOUNITS'
4928       common /calcthet/ term1,term2,termm,diffak,ratak,
4929      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4930      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4931 C Calculate the contributions to both Gaussian lobes.
4932 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4933 C The "polynomial part" of the "standard deviation" of this part of
4934 C the distribution.
4935         sig=polthet(3,it)
4936         do j=2,0,-1
4937           sig=sig*thet_pred_mean+polthet(j,it)
4938         enddo
4939 C Derivative of the "interior part" of the "standard deviation of the"
4940 C gamma-dependent Gaussian lobe in t_c.
4941         sigtc=3*polthet(3,it)
4942         do j=2,1,-1
4943           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4944         enddo
4945         sigtc=sig*sigtc
4946 C Set the parameters of both Gaussian lobes of the distribution.
4947 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4948         fac=sig*sig+sigc0(it)
4949         sigcsq=fac+fac
4950         sigc=1.0D0/sigcsq
4951 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4952         sigsqtc=-4.0D0*sigcsq*sigtc
4953 c       print *,i,sig,sigtc,sigsqtc
4954 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4955         sigtc=-sigtc/(fac*fac)
4956 C Following variable is sigma(t_c)**(-2)
4957         sigcsq=sigcsq*sigcsq
4958         sig0i=sig0(it)
4959         sig0inv=1.0D0/sig0i**2
4960         delthec=thetai-thet_pred_mean
4961         delthe0=thetai-theta0i
4962         term1=-0.5D0*sigcsq*delthec*delthec
4963         term2=-0.5D0*sig0inv*delthe0*delthe0
4964 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4965 C NaNs in taking the logarithm. We extract the largest exponent which is added
4966 C to the energy (this being the log of the distribution) at the end of energy
4967 C term evaluation for this virtual-bond angle.
4968         if (term1.gt.term2) then
4969           termm=term1
4970           term2=dexp(term2-termm)
4971           term1=1.0d0
4972         else
4973           termm=term2
4974           term1=dexp(term1-termm)
4975           term2=1.0d0
4976         endif
4977 C The ratio between the gamma-independent and gamma-dependent lobes of
4978 C the distribution is a Gaussian function of thet_pred_mean too.
4979         diffak=gthet(2,it)-thet_pred_mean
4980         ratak=diffak/gthet(3,it)**2
4981         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4982 C Let's differentiate it in thet_pred_mean NOW.
4983         aktc=ak*ratak
4984 C Now put together the distribution terms to make complete distribution.
4985         termexp=term1+ak*term2
4986         termpre=sigc+ak*sig0i
4987 C Contribution of the bending energy from this theta is just the -log of
4988 C the sum of the contributions from the two lobes and the pre-exponential
4989 C factor. Simple enough, isn't it?
4990         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4991 C NOW the derivatives!!!
4992 C 6/6/97 Take into account the deformation.
4993         E_theta=(delthec*sigcsq*term1
4994      &       +ak*delthe0*sig0inv*term2)/termexp
4995         E_tc=((sigtc+aktc*sig0i)/termpre
4996      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4997      &       aktc*term2)/termexp)
4998       return
4999       end
5000 c-----------------------------------------------------------------------------
5001       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5002       implicit real*8 (a-h,o-z)
5003       include 'DIMENSIONS'
5004       include 'COMMON.LOCAL'
5005       include 'COMMON.IOUNITS'
5006       common /calcthet/ term1,term2,termm,diffak,ratak,
5007      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5008      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5009       delthec=thetai-thet_pred_mean
5010       delthe0=thetai-theta0i
5011 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5012       t3 = thetai-thet_pred_mean
5013       t6 = t3**2
5014       t9 = term1
5015       t12 = t3*sigcsq
5016       t14 = t12+t6*sigsqtc
5017       t16 = 1.0d0
5018       t21 = thetai-theta0i
5019       t23 = t21**2
5020       t26 = term2
5021       t27 = t21*t26
5022       t32 = termexp
5023       t40 = t32**2
5024       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5025      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5026      & *(-t12*t9-ak*sig0inv*t27)
5027       return
5028       end
5029 #else
5030 C--------------------------------------------------------------------------
5031       subroutine ebend(etheta)
5032 C
5033 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5034 C angles gamma and its derivatives in consecutive thetas and gammas.
5035 C ab initio-derived potentials from
5036 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5037 C
5038       implicit real*8 (a-h,o-z)
5039       include 'DIMENSIONS'
5040       include 'COMMON.LOCAL'
5041       include 'COMMON.GEO'
5042       include 'COMMON.INTERACT'
5043       include 'COMMON.DERIV'
5044       include 'COMMON.VAR'
5045       include 'COMMON.CHAIN'
5046       include 'COMMON.IOUNITS'
5047       include 'COMMON.NAMES'
5048       include 'COMMON.FFIELD'
5049       include 'COMMON.CONTROL'
5050       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5051      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5052      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5053      & sinph1ph2(maxdouble,maxdouble)
5054       logical lprn /.false./, lprn1 /.false./
5055       etheta=0.0D0
5056 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5057       do i=ithet_start,ithet_end
5058         dethetai=0.0d0
5059         dephii=0.0d0
5060         dephii1=0.0d0
5061         theti2=0.5d0*theta(i)
5062         ityp2=ithetyp(itype(i-1))
5063         do k=1,nntheterm
5064           coskt(k)=dcos(k*theti2)
5065           sinkt(k)=dsin(k*theti2)
5066         enddo
5067         if (i.gt.3) then
5068 #ifdef OSF
5069           phii=phi(i)
5070           if (phii.ne.phii) phii=150.0
5071 #else
5072           phii=phi(i)
5073 #endif
5074           ityp1=ithetyp(itype(i-2))
5075           do k=1,nsingle
5076             cosph1(k)=dcos(k*phii)
5077             sinph1(k)=dsin(k*phii)
5078           enddo
5079         else
5080           phii=0.0d0
5081           ityp1=nthetyp+1
5082           do k=1,nsingle
5083             cosph1(k)=0.0d0
5084             sinph1(k)=0.0d0
5085           enddo
5086         endif
5087         if (i.lt.nres) then
5088 #ifdef OSF
5089           phii1=phi(i+1)
5090           if (phii1.ne.phii1) phii1=150.0
5091           phii1=pinorm(phii1)
5092 #else
5093           phii1=phi(i+1)
5094 #endif
5095           ityp3=ithetyp(itype(i))
5096           do k=1,nsingle
5097             cosph2(k)=dcos(k*phii1)
5098             sinph2(k)=dsin(k*phii1)
5099           enddo
5100         else
5101           phii1=0.0d0
5102           ityp3=nthetyp+1
5103           do k=1,nsingle
5104             cosph2(k)=0.0d0
5105             sinph2(k)=0.0d0
5106           enddo
5107         endif
5108 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5109 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5110 c        call flush(iout)
5111         ethetai=aa0thet(ityp1,ityp2,ityp3)
5112         do k=1,ndouble
5113           do l=1,k-1
5114             ccl=cosph1(l)*cosph2(k-l)
5115             ssl=sinph1(l)*sinph2(k-l)
5116             scl=sinph1(l)*cosph2(k-l)
5117             csl=cosph1(l)*sinph2(k-l)
5118             cosph1ph2(l,k)=ccl-ssl
5119             cosph1ph2(k,l)=ccl+ssl
5120             sinph1ph2(l,k)=scl+csl
5121             sinph1ph2(k,l)=scl-csl
5122           enddo
5123         enddo
5124         if (lprn) then
5125         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5126      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5127         write (iout,*) "coskt and sinkt"
5128         do k=1,nntheterm
5129           write (iout,*) k,coskt(k),sinkt(k)
5130         enddo
5131         endif
5132         do k=1,ntheterm
5133           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
5134           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
5135      &      *coskt(k)
5136           if (lprn)
5137      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
5138      &     " ethetai",ethetai
5139         enddo
5140         if (lprn) then
5141         write (iout,*) "cosph and sinph"
5142         do k=1,nsingle
5143           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5144         enddo
5145         write (iout,*) "cosph1ph2 and sinph2ph2"
5146         do k=2,ndouble
5147           do l=1,k-1
5148             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5149      &         sinph1ph2(l,k),sinph1ph2(k,l)
5150           enddo
5151         enddo
5152         write(iout,*) "ethetai",ethetai
5153         endif
5154         do m=1,ntheterm2
5155           do k=1,nsingle
5156             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
5157      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
5158      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
5159      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
5160             ethetai=ethetai+sinkt(m)*aux
5161             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5162             dephii=dephii+k*sinkt(m)*(
5163      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
5164      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
5165             dephii1=dephii1+k*sinkt(m)*(
5166      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
5167      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
5168             if (lprn)
5169      &      write (iout,*) "m",m," k",k," bbthet",
5170      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
5171      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
5172      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
5173      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5174           enddo
5175         enddo
5176         if (lprn)
5177      &  write(iout,*) "ethetai",ethetai
5178         do m=1,ntheterm3
5179           do k=2,ndouble
5180             do l=1,k-1
5181               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5182      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
5183      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5184      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
5185               ethetai=ethetai+sinkt(m)*aux
5186               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5187               dephii=dephii+l*sinkt(m)*(
5188      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
5189      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5190      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5191      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5192               dephii1=dephii1+(k-l)*sinkt(m)*(
5193      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5194      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5195      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5196      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5197               if (lprn) then
5198               write (iout,*) "m",m," k",k," l",l," ffthet",
5199      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5200      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5201      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5202      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5203               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5204      &            cosph1ph2(k,l)*sinkt(m),
5205      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5206               endif
5207             enddo
5208           enddo
5209         enddo
5210 10      continue
5211         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5212      &   i,theta(i)*rad2deg,phii*rad2deg,
5213      &   phii1*rad2deg,ethetai
5214         etheta=etheta+ethetai
5215         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5216         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5217         gloc(nphi+i-2,icg)=wang*dethetai
5218       enddo
5219       return
5220       end
5221 #endif
5222 #ifdef CRYST_SC
5223 c-----------------------------------------------------------------------------
5224       subroutine esc(escloc)
5225 C Calculate the local energy of a side chain and its derivatives in the
5226 C corresponding virtual-bond valence angles THETA and the spherical angles
5227 C ALPHA and OMEGA.
5228       implicit real*8 (a-h,o-z)
5229       include 'DIMENSIONS'
5230       include 'sizesclu.dat'
5231       include 'COMMON.GEO'
5232       include 'COMMON.LOCAL'
5233       include 'COMMON.VAR'
5234       include 'COMMON.INTERACT'
5235       include 'COMMON.DERIV'
5236       include 'COMMON.CHAIN'
5237       include 'COMMON.IOUNITS'
5238       include 'COMMON.NAMES'
5239       include 'COMMON.FFIELD'
5240       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5241      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5242       common /sccalc/ time11,time12,time112,theti,it,nlobit
5243       delta=0.02d0*pi
5244       escloc=0.0D0
5245 c     write (iout,'(a)') 'ESC'
5246       do i=loc_start,loc_end
5247         it=itype(i)
5248         if (it.eq.10) goto 1
5249         nlobit=nlob(it)
5250 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5251 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5252         theti=theta(i+1)-pipol
5253         x(1)=dtan(theti)
5254         x(2)=alph(i)
5255         x(3)=omeg(i)
5256 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5257
5258         if (x(2).gt.pi-delta) then
5259           xtemp(1)=x(1)
5260           xtemp(2)=pi-delta
5261           xtemp(3)=x(3)
5262           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5263           xtemp(2)=pi
5264           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5265           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5266      &        escloci,dersc(2))
5267           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5268      &        ddersc0(1),dersc(1))
5269           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5270      &        ddersc0(3),dersc(3))
5271           xtemp(2)=pi-delta
5272           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5273           xtemp(2)=pi
5274           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5275           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5276      &            dersc0(2),esclocbi,dersc02)
5277           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5278      &            dersc12,dersc01)
5279           call splinthet(x(2),0.5d0*delta,ss,ssd)
5280           dersc0(1)=dersc01
5281           dersc0(2)=dersc02
5282           dersc0(3)=0.0d0
5283           do k=1,3
5284             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5285           enddo
5286           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5287 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5288 c    &             esclocbi,ss,ssd
5289           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5290 c         escloci=esclocbi
5291 c         write (iout,*) escloci
5292         else if (x(2).lt.delta) then
5293           xtemp(1)=x(1)
5294           xtemp(2)=delta
5295           xtemp(3)=x(3)
5296           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5297           xtemp(2)=0.0d0
5298           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5299           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5300      &        escloci,dersc(2))
5301           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5302      &        ddersc0(1),dersc(1))
5303           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5304      &        ddersc0(3),dersc(3))
5305           xtemp(2)=delta
5306           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5307           xtemp(2)=0.0d0
5308           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5309           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5310      &            dersc0(2),esclocbi,dersc02)
5311           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5312      &            dersc12,dersc01)
5313           dersc0(1)=dersc01
5314           dersc0(2)=dersc02
5315           dersc0(3)=0.0d0
5316           call splinthet(x(2),0.5d0*delta,ss,ssd)
5317           do k=1,3
5318             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5319           enddo
5320           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5321 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5322 c    &             esclocbi,ss,ssd
5323           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5324 c         write (iout,*) escloci
5325         else
5326           call enesc(x,escloci,dersc,ddummy,.false.)
5327         endif
5328
5329         escloc=escloc+escloci
5330 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5331
5332         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5333      &   wscloc*dersc(1)
5334         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5335         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5336     1   continue
5337       enddo
5338       return
5339       end
5340 C---------------------------------------------------------------------------
5341       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5342       implicit real*8 (a-h,o-z)
5343       include 'DIMENSIONS'
5344       include 'COMMON.GEO'
5345       include 'COMMON.LOCAL'
5346       include 'COMMON.IOUNITS'
5347       common /sccalc/ time11,time12,time112,theti,it,nlobit
5348       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5349       double precision contr(maxlob,-1:1)
5350       logical mixed
5351 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5352         escloc_i=0.0D0
5353         do j=1,3
5354           dersc(j)=0.0D0
5355           if (mixed) ddersc(j)=0.0d0
5356         enddo
5357         x3=x(3)
5358
5359 C Because of periodicity of the dependence of the SC energy in omega we have
5360 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5361 C To avoid underflows, first compute & store the exponents.
5362
5363         do iii=-1,1
5364
5365           x(3)=x3+iii*dwapi
5366
5367           do j=1,nlobit
5368             do k=1,3
5369               z(k)=x(k)-censc(k,j,it)
5370             enddo
5371             do k=1,3
5372               Axk=0.0D0
5373               do l=1,3
5374                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5375               enddo
5376               Ax(k,j,iii)=Axk
5377             enddo
5378             expfac=0.0D0
5379             do k=1,3
5380               expfac=expfac+Ax(k,j,iii)*z(k)
5381             enddo
5382             contr(j,iii)=expfac
5383           enddo ! j
5384
5385         enddo ! iii
5386
5387         x(3)=x3
5388 C As in the case of ebend, we want to avoid underflows in exponentiation and
5389 C subsequent NaNs and INFs in energy calculation.
5390 C Find the largest exponent
5391         emin=contr(1,-1)
5392         do iii=-1,1
5393           do j=1,nlobit
5394             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5395           enddo
5396         enddo
5397         emin=0.5D0*emin
5398 cd      print *,'it=',it,' emin=',emin
5399
5400 C Compute the contribution to SC energy and derivatives
5401         do iii=-1,1
5402
5403           do j=1,nlobit
5404             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5405 cd          print *,'j=',j,' expfac=',expfac
5406             escloc_i=escloc_i+expfac
5407             do k=1,3
5408               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5409             enddo
5410             if (mixed) then
5411               do k=1,3,2
5412                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5413      &            +gaussc(k,2,j,it))*expfac
5414               enddo
5415             endif
5416           enddo
5417
5418         enddo ! iii
5419
5420         dersc(1)=dersc(1)/cos(theti)**2
5421         ddersc(1)=ddersc(1)/cos(theti)**2
5422         ddersc(3)=ddersc(3)
5423
5424         escloci=-(dlog(escloc_i)-emin)
5425         do j=1,3
5426           dersc(j)=dersc(j)/escloc_i
5427         enddo
5428         if (mixed) then
5429           do j=1,3,2
5430             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5431           enddo
5432         endif
5433       return
5434       end
5435 C------------------------------------------------------------------------------
5436       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5437       implicit real*8 (a-h,o-z)
5438       include 'DIMENSIONS'
5439       include 'COMMON.GEO'
5440       include 'COMMON.LOCAL'
5441       include 'COMMON.IOUNITS'
5442       common /sccalc/ time11,time12,time112,theti,it,nlobit
5443       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5444       double precision contr(maxlob)
5445       logical mixed
5446
5447       escloc_i=0.0D0
5448
5449       do j=1,3
5450         dersc(j)=0.0D0
5451       enddo
5452
5453       do j=1,nlobit
5454         do k=1,2
5455           z(k)=x(k)-censc(k,j,it)
5456         enddo
5457         z(3)=dwapi
5458         do k=1,3
5459           Axk=0.0D0
5460           do l=1,3
5461             Axk=Axk+gaussc(l,k,j,it)*z(l)
5462           enddo
5463           Ax(k,j)=Axk
5464         enddo
5465         expfac=0.0D0
5466         do k=1,3
5467           expfac=expfac+Ax(k,j)*z(k)
5468         enddo
5469         contr(j)=expfac
5470       enddo ! j
5471
5472 C As in the case of ebend, we want to avoid underflows in exponentiation and
5473 C subsequent NaNs and INFs in energy calculation.
5474 C Find the largest exponent
5475       emin=contr(1)
5476       do j=1,nlobit
5477         if (emin.gt.contr(j)) emin=contr(j)
5478       enddo
5479       emin=0.5D0*emin
5480
5481 C Compute the contribution to SC energy and derivatives
5482
5483       dersc12=0.0d0
5484       do j=1,nlobit
5485         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5486         escloc_i=escloc_i+expfac
5487         do k=1,2
5488           dersc(k)=dersc(k)+Ax(k,j)*expfac
5489         enddo
5490         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5491      &            +gaussc(1,2,j,it))*expfac
5492         dersc(3)=0.0d0
5493       enddo
5494
5495       dersc(1)=dersc(1)/cos(theti)**2
5496       dersc12=dersc12/cos(theti)**2
5497       escloci=-(dlog(escloc_i)-emin)
5498       do j=1,2
5499         dersc(j)=dersc(j)/escloc_i
5500       enddo
5501       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5502       return
5503       end
5504 #else
5505 c----------------------------------------------------------------------------------
5506       subroutine esc(escloc)
5507 C Calculate the local energy of a side chain and its derivatives in the
5508 C corresponding virtual-bond valence angles THETA and the spherical angles
5509 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5510 C added by Urszula Kozlowska. 07/11/2007
5511 C
5512       implicit real*8 (a-h,o-z)
5513       include 'DIMENSIONS'
5514       include 'COMMON.GEO'
5515       include 'COMMON.LOCAL'
5516       include 'COMMON.VAR'
5517       include 'COMMON.SCROT'
5518       include 'COMMON.INTERACT'
5519       include 'COMMON.DERIV'
5520       include 'COMMON.CHAIN'
5521       include 'COMMON.IOUNITS'
5522       include 'COMMON.NAMES'
5523       include 'COMMON.FFIELD'
5524       include 'COMMON.CONTROL'
5525       include 'COMMON.VECTORS'
5526       double precision x_prime(3),y_prime(3),z_prime(3)
5527      &    , sumene,dsc_i,dp2_i,x(65),
5528      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5529      &    de_dxx,de_dyy,de_dzz,de_dt
5530       double precision s1_t,s1_6_t,s2_t,s2_6_t
5531       double precision
5532      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5533      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5534      & dt_dCi(3),dt_dCi1(3)
5535       common /sccalc/ time11,time12,time112,theti,it,nlobit
5536       delta=0.02d0*pi
5537       escloc=0.0D0
5538       do i=loc_start,loc_end
5539         costtab(i+1) =dcos(theta(i+1))
5540         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5541         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5542         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5543         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5544         cosfac=dsqrt(cosfac2)
5545         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5546         sinfac=dsqrt(sinfac2)
5547         it=itype(i)
5548         if (it.eq.10) goto 1
5549 c
5550 C  Compute the axes of tghe local cartesian coordinates system; store in
5551 c   x_prime, y_prime and z_prime
5552 c
5553         do j=1,3
5554           x_prime(j) = 0.00
5555           y_prime(j) = 0.00
5556           z_prime(j) = 0.00
5557         enddo
5558 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5559 C     &   dc_norm(3,i+nres)
5560         do j = 1,3
5561           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5562           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5563         enddo
5564         do j = 1,3
5565           z_prime(j) = -uz(j,i-1)
5566         enddo
5567 c       write (2,*) "i",i
5568 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5569 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5570 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5571 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5572 c      & " xy",scalar(x_prime(1),y_prime(1)),
5573 c      & " xz",scalar(x_prime(1),z_prime(1)),
5574 c      & " yy",scalar(y_prime(1),y_prime(1)),
5575 c      & " yz",scalar(y_prime(1),z_prime(1)),
5576 c      & " zz",scalar(z_prime(1),z_prime(1))
5577 c
5578 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5579 C to local coordinate system. Store in xx, yy, zz.
5580 c
5581         xx=0.0d0
5582         yy=0.0d0
5583         zz=0.0d0
5584         do j = 1,3
5585           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5586           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5587           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5588         enddo
5589
5590         xxtab(i)=xx
5591         yytab(i)=yy
5592         zztab(i)=zz
5593 C
5594 C Compute the energy of the ith side cbain
5595 C
5596 c        write (2,*) "xx",xx," yy",yy," zz",zz
5597         it=itype(i)
5598         do j = 1,65
5599           x(j) = sc_parmin(j,it)
5600         enddo
5601 #ifdef CHECK_COORD
5602 Cc diagnostics - remove later
5603         xx1 = dcos(alph(2))
5604         yy1 = dsin(alph(2))*dcos(omeg(2))
5605         zz1 = -dsin(alph(2))*dsin(omeg(2))
5606         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5607      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5608      &    xx1,yy1,zz1
5609 C,"  --- ", xx_w,yy_w,zz_w
5610 c end diagnostics
5611 #endif
5612         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5613      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5614      &   + x(10)*yy*zz
5615         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5616      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5617      & + x(20)*yy*zz
5618         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5619      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5620      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5621      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5622      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5623      &  +x(40)*xx*yy*zz
5624         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5625      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5626      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5627      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5628      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5629      &  +x(60)*xx*yy*zz
5630         dsc_i   = 0.743d0+x(61)
5631         dp2_i   = 1.9d0+x(62)
5632         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5633      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5634         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5635      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5636         s1=(1+x(63))/(0.1d0 + dscp1)
5637         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5638         s2=(1+x(65))/(0.1d0 + dscp2)
5639         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5640         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5641      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5642 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5643 c     &   sumene4,
5644 c     &   dscp1,dscp2,sumene
5645 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5646         escloc = escloc + sumene
5647 c        write (2,*) "escloc",escloc
5648         if (.not. calc_grad) goto 1
5649 #ifdef DEBUG
5650 C
5651 C This section to check the numerical derivatives of the energy of ith side
5652 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5653 C #define DEBUG in the code to turn it on.
5654 C
5655         write (2,*) "sumene               =",sumene
5656         aincr=1.0d-7
5657         xxsave=xx
5658         xx=xx+aincr
5659         write (2,*) xx,yy,zz
5660         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5661         de_dxx_num=(sumenep-sumene)/aincr
5662         xx=xxsave
5663         write (2,*) "xx+ sumene from enesc=",sumenep
5664         yysave=yy
5665         yy=yy+aincr
5666         write (2,*) xx,yy,zz
5667         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5668         de_dyy_num=(sumenep-sumene)/aincr
5669         yy=yysave
5670         write (2,*) "yy+ sumene from enesc=",sumenep
5671         zzsave=zz
5672         zz=zz+aincr
5673         write (2,*) xx,yy,zz
5674         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5675         de_dzz_num=(sumenep-sumene)/aincr
5676         zz=zzsave
5677         write (2,*) "zz+ sumene from enesc=",sumenep
5678         costsave=cost2tab(i+1)
5679         sintsave=sint2tab(i+1)
5680         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5681         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5682         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5683         de_dt_num=(sumenep-sumene)/aincr
5684         write (2,*) " t+ sumene from enesc=",sumenep
5685         cost2tab(i+1)=costsave
5686         sint2tab(i+1)=sintsave
5687 C End of diagnostics section.
5688 #endif
5689 C
5690 C Compute the gradient of esc
5691 C
5692         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5693         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5694         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5695         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5696         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5697         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5698         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5699         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5700         pom1=(sumene3*sint2tab(i+1)+sumene1)
5701      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5702         pom2=(sumene4*cost2tab(i+1)+sumene2)
5703      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5704         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5705         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5706      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5707      &  +x(40)*yy*zz
5708         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5709         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5710      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5711      &  +x(60)*yy*zz
5712         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5713      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5714      &        +(pom1+pom2)*pom_dx
5715 #ifdef DEBUG
5716         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5717 #endif
5718 C
5719         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5720         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5721      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5722      &  +x(40)*xx*zz
5723         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5724         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5725      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5726      &  +x(59)*zz**2 +x(60)*xx*zz
5727         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5728      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5729      &        +(pom1-pom2)*pom_dy
5730 #ifdef DEBUG
5731         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5732 #endif
5733 C
5734         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5735      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5736      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5737      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5738      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5739      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5740      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5741      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5742 #ifdef DEBUG
5743         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5744 #endif
5745 C
5746         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5747      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5748      &  +pom1*pom_dt1+pom2*pom_dt2
5749 #ifdef DEBUG
5750         write(2,*), "de_dt = ", de_dt,de_dt_num
5751 #endif
5752 c
5753 C
5754        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5755        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5756        cosfac2xx=cosfac2*xx
5757        sinfac2yy=sinfac2*yy
5758        do k = 1,3
5759          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5760      &      vbld_inv(i+1)
5761          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5762      &      vbld_inv(i)
5763          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5764          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5765 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5766 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5767 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5768 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5769          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5770          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5771          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5772          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5773          dZZ_Ci1(k)=0.0d0
5774          dZZ_Ci(k)=0.0d0
5775          do j=1,3
5776            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5777            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5778          enddo
5779
5780          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5781          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5782          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5783 c
5784          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5785          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5786        enddo
5787
5788        do k=1,3
5789          dXX_Ctab(k,i)=dXX_Ci(k)
5790          dXX_C1tab(k,i)=dXX_Ci1(k)
5791          dYY_Ctab(k,i)=dYY_Ci(k)
5792          dYY_C1tab(k,i)=dYY_Ci1(k)
5793          dZZ_Ctab(k,i)=dZZ_Ci(k)
5794          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5795          dXX_XYZtab(k,i)=dXX_XYZ(k)
5796          dYY_XYZtab(k,i)=dYY_XYZ(k)
5797          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5798        enddo
5799
5800        do k = 1,3
5801 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5802 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5803 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5804 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5805 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5806 c     &    dt_dci(k)
5807 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5808 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5809          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5810      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5811          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5812      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5813          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5814      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5815        enddo
5816 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5817 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5818
5819 C to check gradient call subroutine check_grad
5820
5821     1 continue
5822       enddo
5823       return
5824       end
5825 #endif
5826 c------------------------------------------------------------------------------
5827       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5828 C
5829 C This procedure calculates two-body contact function g(rij) and its derivative:
5830 C
5831 C           eps0ij                                     !       x < -1
5832 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5833 C            0                                         !       x > 1
5834 C
5835 C where x=(rij-r0ij)/delta
5836 C
5837 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5838 C
5839       implicit none
5840       double precision rij,r0ij,eps0ij,fcont,fprimcont
5841       double precision x,x2,x4,delta
5842 c     delta=0.02D0*r0ij
5843 c      delta=0.2D0*r0ij
5844       x=(rij-r0ij)/delta
5845       if (x.lt.-1.0D0) then
5846         fcont=eps0ij
5847         fprimcont=0.0D0
5848       else if (x.le.1.0D0) then
5849         x2=x*x
5850         x4=x2*x2
5851         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5852         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5853       else
5854         fcont=0.0D0
5855         fprimcont=0.0D0
5856       endif
5857       return
5858       end
5859 c------------------------------------------------------------------------------
5860       subroutine splinthet(theti,delta,ss,ssder)
5861       implicit real*8 (a-h,o-z)
5862       include 'DIMENSIONS'
5863       include 'sizesclu.dat'
5864       include 'COMMON.VAR'
5865       include 'COMMON.GEO'
5866       thetup=pi-delta
5867       thetlow=delta
5868       if (theti.gt.pipol) then
5869         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5870       else
5871         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5872         ssder=-ssder
5873       endif
5874       return
5875       end
5876 c------------------------------------------------------------------------------
5877       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5878       implicit none
5879       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5880       double precision ksi,ksi2,ksi3,a1,a2,a3
5881       a1=fprim0*delta/(f1-f0)
5882       a2=3.0d0-2.0d0*a1
5883       a3=a1-2.0d0
5884       ksi=(x-x0)/delta
5885       ksi2=ksi*ksi
5886       ksi3=ksi2*ksi
5887       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5888       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5889       return
5890       end
5891 c------------------------------------------------------------------------------
5892       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5893       implicit none
5894       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5895       double precision ksi,ksi2,ksi3,a1,a2,a3
5896       ksi=(x-x0)/delta
5897       ksi2=ksi*ksi
5898       ksi3=ksi2*ksi
5899       a1=fprim0x*delta
5900       a2=3*(f1x-f0x)-2*fprim0x*delta
5901       a3=fprim0x*delta-2*(f1x-f0x)
5902       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5903       return
5904       end
5905 C-----------------------------------------------------------------------------
5906 #ifdef CRYST_TOR
5907 C-----------------------------------------------------------------------------
5908       subroutine etor(etors,edihcnstr,fact)
5909       implicit real*8 (a-h,o-z)
5910       include 'DIMENSIONS'
5911       include 'sizesclu.dat'
5912       include 'COMMON.VAR'
5913       include 'COMMON.GEO'
5914       include 'COMMON.LOCAL'
5915       include 'COMMON.TORSION'
5916       include 'COMMON.INTERACT'
5917       include 'COMMON.DERIV'
5918       include 'COMMON.CHAIN'
5919       include 'COMMON.NAMES'
5920       include 'COMMON.IOUNITS'
5921       include 'COMMON.FFIELD'
5922       include 'COMMON.TORCNSTR'
5923       logical lprn
5924 C Set lprn=.true. for debugging
5925       lprn=.false.
5926 c      lprn=.true.
5927       etors=0.0D0
5928       do i=iphi_start,iphi_end
5929         itori=itortyp(itype(i-2))
5930         itori1=itortyp(itype(i-1))
5931         phii=phi(i)
5932         gloci=0.0D0
5933 C Proline-Proline pair is a special case...
5934         if (itori.eq.3 .and. itori1.eq.3) then
5935           if (phii.gt.-dwapi3) then
5936             cosphi=dcos(3*phii)
5937             fac=1.0D0/(1.0D0-cosphi)
5938             etorsi=v1(1,3,3)*fac
5939             etorsi=etorsi+etorsi
5940             etors=etors+etorsi-v1(1,3,3)
5941             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5942           endif
5943           do j=1,3
5944             v1ij=v1(j+1,itori,itori1)
5945             v2ij=v2(j+1,itori,itori1)
5946             cosphi=dcos(j*phii)
5947             sinphi=dsin(j*phii)
5948             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5949             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5950           enddo
5951         else
5952           do j=1,nterm_old
5953             v1ij=v1(j,itori,itori1)
5954             v2ij=v2(j,itori,itori1)
5955             cosphi=dcos(j*phii)
5956             sinphi=dsin(j*phii)
5957             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5958             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5959           enddo
5960         endif
5961         if (lprn)
5962      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5963      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5964      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5965         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5966 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5967       enddo
5968 ! 6/20/98 - dihedral angle constraints
5969       edihcnstr=0.0d0
5970       do i=1,ndih_constr
5971         itori=idih_constr(i)
5972         phii=phi(itori)
5973         difi=pinorm(phii-phi0(i))
5974         if (difi.gt.drange(i)) then
5975           difi=difi-drange(i)
5976           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5977           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5978         else if (difi.lt.-drange(i)) then
5979           difi=difi+drange(i)
5980           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5981           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5982         endif
5983 c        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5984 c     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5985       enddo
5986       write (iout,*) 'edihcnstr',edihcnstr
5987       return
5988       end
5989 c------------------------------------------------------------------------------
5990 #else
5991       subroutine etor(etors,edihcnstr,fact)
5992       implicit real*8 (a-h,o-z)
5993       include 'DIMENSIONS'
5994       include 'sizesclu.dat'
5995       include 'COMMON.VAR'
5996       include 'COMMON.GEO'
5997       include 'COMMON.LOCAL'
5998       include 'COMMON.TORSION'
5999       include 'COMMON.INTERACT'
6000       include 'COMMON.DERIV'
6001       include 'COMMON.CHAIN'
6002       include 'COMMON.NAMES'
6003       include 'COMMON.IOUNITS'
6004       include 'COMMON.FFIELD'
6005       include 'COMMON.TORCNSTR'
6006       logical lprn
6007 C Set lprn=.true. for debugging
6008       lprn=.false.
6009 c      lprn=.true.
6010       etors=0.0D0
6011       do i=iphi_start,iphi_end
6012         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6013         itori=itortyp(itype(i-2))
6014         itori1=itortyp(itype(i-1))
6015         phii=phi(i)
6016         gloci=0.0D0
6017 C Regular cosine and sine terms
6018         do j=1,nterm(itori,itori1)
6019           v1ij=v1(j,itori,itori1)
6020           v2ij=v2(j,itori,itori1)
6021           cosphi=dcos(j*phii)
6022           sinphi=dsin(j*phii)
6023           etors=etors+v1ij*cosphi+v2ij*sinphi
6024           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6025         enddo
6026 C Lorentz terms
6027 C                         v1
6028 C  E = SUM ----------------------------------- - v1
6029 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6030 C
6031         cosphi=dcos(0.5d0*phii)
6032         sinphi=dsin(0.5d0*phii)
6033         do j=1,nlor(itori,itori1)
6034           vl1ij=vlor1(j,itori,itori1)
6035           vl2ij=vlor2(j,itori,itori1)
6036           vl3ij=vlor3(j,itori,itori1)
6037           pom=vl2ij*cosphi+vl3ij*sinphi
6038           pom1=1.0d0/(pom*pom+1.0d0)
6039           etors=etors+vl1ij*pom1
6040           pom=-pom*pom1*pom1
6041           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6042         enddo
6043 C Subtract the constant term
6044         etors=etors-v0(itori,itori1)
6045         if (lprn)
6046      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6047      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6048      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6049         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6050 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6051  1215   continue
6052       enddo
6053 ! 6/20/98 - dihedral angle constraints
6054       edihcnstr=0.0d0
6055 c      write (iout,*) "Dihedral angle restraint energy"
6056       do i=1,ndih_constr
6057         itori=idih_constr(i)
6058         phii=phi(itori)
6059         difi=pinorm(phii-phi0(i))
6060 c        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6061 c     &    rad2deg*difi,rad2deg*phi0(i),rad2deg*drange(i)
6062         if (difi.gt.drange(i)) then
6063           difi=difi-drange(i)
6064           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6065           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6066 c          write (iout,*) 0.25d0*ftors*difi**4
6067         else if (difi.lt.-drange(i)) then
6068           difi=difi+drange(i)
6069           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6070           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6071 c          write (iout,*) 0.25d0*ftors*difi**4
6072         endif
6073       enddo
6074 c      write (iout,*) 'edihcnstr',edihcnstr
6075       return
6076       end
6077 c----------------------------------------------------------------------------
6078       subroutine etor_d(etors_d,fact2)
6079 C 6/23/01 Compute double torsional energy
6080       implicit real*8 (a-h,o-z)
6081       include 'DIMENSIONS'
6082       include 'sizesclu.dat'
6083       include 'COMMON.VAR'
6084       include 'COMMON.GEO'
6085       include 'COMMON.LOCAL'
6086       include 'COMMON.TORSION'
6087       include 'COMMON.INTERACT'
6088       include 'COMMON.DERIV'
6089       include 'COMMON.CHAIN'
6090       include 'COMMON.NAMES'
6091       include 'COMMON.IOUNITS'
6092       include 'COMMON.FFIELD'
6093       include 'COMMON.TORCNSTR'
6094       logical lprn
6095 C Set lprn=.true. for debugging
6096       lprn=.false.
6097 c     lprn=.true.
6098       etors_d=0.0D0
6099       do i=iphi_start,iphi_end-1
6100         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6101      &     goto 1215
6102         itori=itortyp(itype(i-2))
6103         itori1=itortyp(itype(i-1))
6104         itori2=itortyp(itype(i))
6105         phii=phi(i)
6106         phii1=phi(i+1)
6107         gloci1=0.0D0
6108         gloci2=0.0D0
6109 C Regular cosine and sine terms
6110         do j=1,ntermd_1(itori,itori1,itori2)
6111           v1cij=v1c(1,j,itori,itori1,itori2)
6112           v1sij=v1s(1,j,itori,itori1,itori2)
6113           v2cij=v1c(2,j,itori,itori1,itori2)
6114           v2sij=v1s(2,j,itori,itori1,itori2)
6115           cosphi1=dcos(j*phii)
6116           sinphi1=dsin(j*phii)
6117           cosphi2=dcos(j*phii1)
6118           sinphi2=dsin(j*phii1)
6119           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6120      &     v2cij*cosphi2+v2sij*sinphi2
6121           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6122           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6123         enddo
6124         do k=2,ntermd_2(itori,itori1,itori2)
6125           do l=1,k-1
6126             v1cdij = v2c(k,l,itori,itori1,itori2)
6127             v2cdij = v2c(l,k,itori,itori1,itori2)
6128             v1sdij = v2s(k,l,itori,itori1,itori2)
6129             v2sdij = v2s(l,k,itori,itori1,itori2)
6130             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6131             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6132             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6133             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6134             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6135      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6136             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6137      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6138             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6139      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6140           enddo
6141         enddo
6142         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6143         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6144  1215   continue
6145       enddo
6146       return
6147       end
6148 #endif
6149 c------------------------------------------------------------------------------
6150       subroutine eback_sc_corr(esccor,fact)
6151 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6152 c        conformational states; temporarily implemented as differences
6153 c        between UNRES torsional potentials (dependent on three types of
6154 c        residues) and the torsional potentials dependent on all 20 types
6155 c        of residues computed from AM1 energy surfaces of terminally-blocked
6156 c        amino-acid residues.
6157       implicit real*8 (a-h,o-z)
6158       include 'DIMENSIONS'
6159       include 'COMMON.VAR'
6160       include 'COMMON.GEO'
6161       include 'COMMON.LOCAL'
6162       include 'COMMON.TORSION'
6163       include 'COMMON.SCCOR'
6164       include 'COMMON.INTERACT'
6165       include 'COMMON.DERIV'
6166       include 'COMMON.CHAIN'
6167       include 'COMMON.NAMES'
6168       include 'COMMON.IOUNITS'
6169       include 'COMMON.FFIELD'
6170       include 'COMMON.CONTROL'
6171       logical lprn
6172 C Set lprn=.true. for debugging
6173       lprn=.false.
6174 c      lprn=.true.
6175 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6176       esccor=0.0D0
6177       do i=itau_start,itau_end
6178         esccor_ii=0.0D0
6179         isccori=isccortyp(itype(i-2))
6180         isccori1=isccortyp(itype(i-1))
6181         phii=phi(i)
6182 cccc  Added 9 May 2012
6183 cc Tauangle is torsional engle depending on the value of first digit
6184 c(see comment below)
6185 cc Omicron is flat angle depending on the value of first digit
6186 c(see comment below)
6187
6188
6189         do intertyp=1,3 !intertyp
6190 cc Added 09 May 2012 (Adasko)
6191 cc  Intertyp means interaction type of backbone mainchain correlation:
6192 c   1 = SC...Ca...Ca...Ca
6193 c   2 = Ca...Ca...Ca...SC
6194 c   3 = SC...Ca...Ca...SCi
6195         gloci=0.0D0
6196         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6197      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6198      &      (itype(i-1).eq.21)))
6199      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6200      &     .or.(itype(i-2).eq.21)))
6201      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6202      &      (itype(i-1).eq.21)))) cycle
6203         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6204         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6205      & cycle
6206         do j=1,nterm_sccor(isccori,isccori1)
6207           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6208           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6209           cosphi=dcos(j*tauangle(intertyp,i))
6210           sinphi=dsin(j*tauangle(intertyp,i))
6211           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6212           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6213         enddo
6214         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6215 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6216 c     &gloc_sc(intertyp,i-3,icg)
6217         if (lprn)
6218      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6219      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6220      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6221      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6222         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6223        enddo !intertyp
6224       enddo
6225
6226       return
6227       end
6228 c------------------------------------------------------------------------------
6229       subroutine multibody(ecorr)
6230 C This subroutine calculates multi-body contributions to energy following
6231 C the idea of Skolnick et al. If side chains I and J make a contact and
6232 C at the same time side chains I+1 and J+1 make a contact, an extra
6233 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6234       implicit real*8 (a-h,o-z)
6235       include 'DIMENSIONS'
6236       include 'COMMON.IOUNITS'
6237       include 'COMMON.DERIV'
6238       include 'COMMON.INTERACT'
6239       include 'COMMON.CONTACTS'
6240       double precision gx(3),gx1(3)
6241       logical lprn
6242
6243 C Set lprn=.true. for debugging
6244       lprn=.false.
6245
6246       if (lprn) then
6247         write (iout,'(a)') 'Contact function values:'
6248         do i=nnt,nct-2
6249           write (iout,'(i2,20(1x,i2,f10.5))')
6250      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6251         enddo
6252       endif
6253       ecorr=0.0D0
6254       do i=nnt,nct
6255         do j=1,3
6256           gradcorr(j,i)=0.0D0
6257           gradxorr(j,i)=0.0D0
6258         enddo
6259       enddo
6260       do i=nnt,nct-2
6261
6262         DO ISHIFT = 3,4
6263
6264         i1=i+ishift
6265         num_conti=num_cont(i)
6266         num_conti1=num_cont(i1)
6267         do jj=1,num_conti
6268           j=jcont(jj,i)
6269           do kk=1,num_conti1
6270             j1=jcont(kk,i1)
6271             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6272 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6273 cd   &                   ' ishift=',ishift
6274 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6275 C The system gains extra energy.
6276               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6277             endif   ! j1==j+-ishift
6278           enddo     ! kk
6279         enddo       ! jj
6280
6281         ENDDO ! ISHIFT
6282
6283       enddo         ! i
6284       return
6285       end
6286 c------------------------------------------------------------------------------
6287       double precision function esccorr(i,j,k,l,jj,kk)
6288       implicit real*8 (a-h,o-z)
6289       include 'DIMENSIONS'
6290       include 'COMMON.IOUNITS'
6291       include 'COMMON.DERIV'
6292       include 'COMMON.INTERACT'
6293       include 'COMMON.CONTACTS'
6294       double precision gx(3),gx1(3)
6295       logical lprn
6296       lprn=.false.
6297       eij=facont(jj,i)
6298       ekl=facont(kk,k)
6299 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6300 C Calculate the multi-body contribution to energy.
6301 C Calculate multi-body contributions to the gradient.
6302 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6303 cd   & k,l,(gacont(m,kk,k),m=1,3)
6304       do m=1,3
6305         gx(m) =ekl*gacont(m,jj,i)
6306         gx1(m)=eij*gacont(m,kk,k)
6307         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6308         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6309         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6310         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6311       enddo
6312       do m=i,j-1
6313         do ll=1,3
6314           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6315         enddo
6316       enddo
6317       do m=k,l-1
6318         do ll=1,3
6319           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6320         enddo
6321       enddo
6322       esccorr=-eij*ekl
6323       return
6324       end
6325 c------------------------------------------------------------------------------
6326 #ifdef MPL
6327       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
6328       implicit real*8 (a-h,o-z)
6329       include 'DIMENSIONS'
6330       integer dimen1,dimen2,atom,indx
6331       double precision buffer(dimen1,dimen2)
6332       double precision zapas
6333       common /contacts_hb/ zapas(3,20,maxres,7),
6334      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6335      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6336       num_kont=num_cont_hb(atom)
6337       do i=1,num_kont
6338         do k=1,7
6339           do j=1,3
6340             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
6341           enddo ! j
6342         enddo ! k
6343         buffer(i,indx+22)=facont_hb(i,atom)
6344         buffer(i,indx+23)=ees0p(i,atom)
6345         buffer(i,indx+24)=ees0m(i,atom)
6346         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
6347       enddo ! i
6348       buffer(1,indx+26)=dfloat(num_kont)
6349       return
6350       end
6351 c------------------------------------------------------------------------------
6352       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
6353       implicit real*8 (a-h,o-z)
6354       include 'DIMENSIONS'
6355       integer dimen1,dimen2,atom,indx
6356       double precision buffer(dimen1,dimen2)
6357       double precision zapas
6358       common /contacts_hb/ zapas(3,20,maxres,7),
6359      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6360      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6361       num_kont=buffer(1,indx+26)
6362       num_kont_old=num_cont_hb(atom)
6363       num_cont_hb(atom)=num_kont+num_kont_old
6364       do i=1,num_kont
6365         ii=i+num_kont_old
6366         do k=1,7
6367           do j=1,3
6368             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
6369           enddo ! j
6370         enddo ! k
6371         facont_hb(ii,atom)=buffer(i,indx+22)
6372         ees0p(ii,atom)=buffer(i,indx+23)
6373         ees0m(ii,atom)=buffer(i,indx+24)
6374         jcont_hb(ii,atom)=buffer(i,indx+25)
6375       enddo ! i
6376       return
6377       end
6378 c------------------------------------------------------------------------------
6379 #endif
6380       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6381 C This subroutine calculates multi-body contributions to hydrogen-bonding
6382       implicit real*8 (a-h,o-z)
6383       include 'DIMENSIONS'
6384       include 'sizesclu.dat'
6385       include 'COMMON.IOUNITS'
6386 #ifdef MPL
6387       include 'COMMON.INFO'
6388 #endif
6389       include 'COMMON.FFIELD'
6390       include 'COMMON.DERIV'
6391       include 'COMMON.INTERACT'
6392       include 'COMMON.CONTACTS'
6393 #ifdef MPL
6394       parameter (max_cont=maxconts)
6395       parameter (max_dim=2*(8*3+2))
6396       parameter (msglen1=max_cont*max_dim*4)
6397       parameter (msglen2=2*msglen1)
6398       integer source,CorrelType,CorrelID,Error
6399       double precision buffer(max_cont,max_dim)
6400 #endif
6401       double precision gx(3),gx1(3)
6402       logical lprn,ldone
6403
6404 C Set lprn=.true. for debugging
6405       lprn=.false.
6406 #ifdef MPL
6407       n_corr=0
6408       n_corr1=0
6409       if (fgProcs.le.1) goto 30
6410       if (lprn) then
6411         write (iout,'(a)') 'Contact function values:'
6412         do i=nnt,nct-2
6413           write (iout,'(2i3,50(1x,i2,f5.2))')
6414      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6415      &    j=1,num_cont_hb(i))
6416         enddo
6417       endif
6418 C Caution! Following code assumes that electrostatic interactions concerning
6419 C a given atom are split among at most two processors!
6420       CorrelType=477
6421       CorrelID=MyID+1
6422       ldone=.false.
6423       do i=1,max_cont
6424         do j=1,max_dim
6425           buffer(i,j)=0.0D0
6426         enddo
6427       enddo
6428       mm=mod(MyRank,2)
6429 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6430       if (mm) 20,20,10
6431    10 continue
6432 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6433       if (MyRank.gt.0) then
6434 C Send correlation contributions to the preceding processor
6435         msglen=msglen1
6436         nn=num_cont_hb(iatel_s)
6437         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6438 cd      write (iout,*) 'The BUFFER array:'
6439 cd      do i=1,nn
6440 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6441 cd      enddo
6442         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6443           msglen=msglen2
6444             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6445 C Clear the contacts of the atom passed to the neighboring processor
6446         nn=num_cont_hb(iatel_s+1)
6447 cd      do i=1,nn
6448 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6449 cd      enddo
6450             num_cont_hb(iatel_s)=0
6451         endif
6452 cd      write (iout,*) 'Processor ',MyID,MyRank,
6453 cd   & ' is sending correlation contribution to processor',MyID-1,
6454 cd   & ' msglen=',msglen
6455 cd      write (*,*) 'Processor ',MyID,MyRank,
6456 cd   & ' is sending correlation contribution to processor',MyID-1,
6457 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6458         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6459 cd      write (iout,*) 'Processor ',MyID,
6460 cd   & ' has sent correlation contribution to processor',MyID-1,
6461 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6462 cd      write (*,*) 'Processor ',MyID,
6463 cd   & ' has sent correlation contribution to processor',MyID-1,
6464 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6465         msglen=msglen1
6466       endif ! (MyRank.gt.0)
6467       if (ldone) goto 30
6468       ldone=.true.
6469    20 continue
6470 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6471       if (MyRank.lt.fgProcs-1) then
6472 C Receive correlation contributions from the next processor
6473         msglen=msglen1
6474         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6475 cd      write (iout,*) 'Processor',MyID,
6476 cd   & ' is receiving correlation contribution from processor',MyID+1,
6477 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6478 cd      write (*,*) 'Processor',MyID,
6479 cd   & ' is receiving correlation contribution from processor',MyID+1,
6480 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6481         nbytes=-1
6482         do while (nbytes.le.0)
6483           call mp_probe(MyID+1,CorrelType,nbytes)
6484         enddo
6485 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6486         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6487 cd      write (iout,*) 'Processor',MyID,
6488 cd   & ' has received correlation contribution from processor',MyID+1,
6489 cd   & ' msglen=',msglen,' nbytes=',nbytes
6490 cd      write (iout,*) 'The received BUFFER array:'
6491 cd      do i=1,max_cont
6492 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6493 cd      enddo
6494         if (msglen.eq.msglen1) then
6495           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6496         else if (msglen.eq.msglen2)  then
6497           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6498           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6499         else
6500           write (iout,*)
6501      & 'ERROR!!!! message length changed while processing correlations.'
6502           write (*,*)
6503      & 'ERROR!!!! message length changed while processing correlations.'
6504           call mp_stopall(Error)
6505         endif ! msglen.eq.msglen1
6506       endif ! MyRank.lt.fgProcs-1
6507       if (ldone) goto 30
6508       ldone=.true.
6509       goto 10
6510    30 continue
6511 #endif
6512       if (lprn) then
6513         write (iout,'(a)') 'Contact function values:'
6514         do i=nnt,nct-2
6515           write (iout,'(2i3,50(1x,i2,f5.2))')
6516      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6517      &    j=1,num_cont_hb(i))
6518         enddo
6519       endif
6520       ecorr=0.0D0
6521 C Remove the loop below after debugging !!!
6522       do i=nnt,nct
6523         do j=1,3
6524           gradcorr(j,i)=0.0D0
6525           gradxorr(j,i)=0.0D0
6526         enddo
6527       enddo
6528 C Calculate the local-electrostatic correlation terms
6529       do i=iatel_s,iatel_e+1
6530         i1=i+1
6531         num_conti=num_cont_hb(i)
6532         num_conti1=num_cont_hb(i+1)
6533         do jj=1,num_conti
6534           j=jcont_hb(jj,i)
6535           do kk=1,num_conti1
6536             j1=jcont_hb(kk,i1)
6537 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6538 c     &         ' jj=',jj,' kk=',kk
6539             if (j1.eq.j+1 .or. j1.eq.j-1) then
6540 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6541 C The system gains extra energy.
6542               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6543               n_corr=n_corr+1
6544             else if (j1.eq.j) then
6545 C Contacts I-J and I-(J+1) occur simultaneously.
6546 C The system loses extra energy.
6547 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6548             endif
6549           enddo ! kk
6550           do kk=1,num_conti
6551             j1=jcont_hb(kk,i)
6552 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6553 c    &         ' jj=',jj,' kk=',kk
6554             if (j1.eq.j+1) then
6555 C Contacts I-J and (I+1)-J occur simultaneously.
6556 C The system loses extra energy.
6557 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6558             endif ! j1==j+1
6559           enddo ! kk
6560         enddo ! jj
6561       enddo ! i
6562       return
6563       end
6564 c------------------------------------------------------------------------------
6565       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6566      &  n_corr1)
6567 C This subroutine calculates multi-body contributions to hydrogen-bonding
6568       implicit real*8 (a-h,o-z)
6569       include 'DIMENSIONS'
6570       include 'sizesclu.dat'
6571       include 'COMMON.IOUNITS'
6572 #ifdef MPL
6573       include 'COMMON.INFO'
6574 #endif
6575       include 'COMMON.FFIELD'
6576       include 'COMMON.DERIV'
6577       include 'COMMON.INTERACT'
6578       include 'COMMON.CONTACTS'
6579 #ifdef MPL
6580       parameter (max_cont=maxconts)
6581       parameter (max_dim=2*(8*3+2))
6582       parameter (msglen1=max_cont*max_dim*4)
6583       parameter (msglen2=2*msglen1)
6584       integer source,CorrelType,CorrelID,Error
6585       double precision buffer(max_cont,max_dim)
6586 #endif
6587       double precision gx(3),gx1(3)
6588       logical lprn,ldone
6589
6590 C Set lprn=.true. for debugging
6591       lprn=.false.
6592       eturn6=0.0d0
6593 #ifdef MPL
6594       n_corr=0
6595       n_corr1=0
6596       if (fgProcs.le.1) goto 30
6597       if (lprn) then
6598         write (iout,'(a)') 'Contact function values:'
6599         do i=nnt,nct-2
6600           write (iout,'(2i3,50(1x,i2,f5.2))')
6601      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6602      &    j=1,num_cont_hb(i))
6603         enddo
6604       endif
6605 C Caution! Following code assumes that electrostatic interactions concerning
6606 C a given atom are split among at most two processors!
6607       CorrelType=477
6608       CorrelID=MyID+1
6609       ldone=.false.
6610       do i=1,max_cont
6611         do j=1,max_dim
6612           buffer(i,j)=0.0D0
6613         enddo
6614       enddo
6615       mm=mod(MyRank,2)
6616 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6617       if (mm) 20,20,10
6618    10 continue
6619 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6620       if (MyRank.gt.0) then
6621 C Send correlation contributions to the preceding processor
6622         msglen=msglen1
6623         nn=num_cont_hb(iatel_s)
6624         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6625 cd      write (iout,*) 'The BUFFER array:'
6626 cd      do i=1,nn
6627 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6628 cd      enddo
6629         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6630           msglen=msglen2
6631             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6632 C Clear the contacts of the atom passed to the neighboring processor
6633         nn=num_cont_hb(iatel_s+1)
6634 cd      do i=1,nn
6635 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6636 cd      enddo
6637             num_cont_hb(iatel_s)=0
6638         endif
6639 cd      write (iout,*) 'Processor ',MyID,MyRank,
6640 cd   & ' is sending correlation contribution to processor',MyID-1,
6641 cd   & ' msglen=',msglen
6642 cd      write (*,*) 'Processor ',MyID,MyRank,
6643 cd   & ' is sending correlation contribution to processor',MyID-1,
6644 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6645         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6646 cd      write (iout,*) 'Processor ',MyID,
6647 cd   & ' has sent correlation contribution to processor',MyID-1,
6648 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6649 cd      write (*,*) 'Processor ',MyID,
6650 cd   & ' has sent correlation contribution to processor',MyID-1,
6651 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6652         msglen=msglen1
6653       endif ! (MyRank.gt.0)
6654       if (ldone) goto 30
6655       ldone=.true.
6656    20 continue
6657 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6658       if (MyRank.lt.fgProcs-1) then
6659 C Receive correlation contributions from the next processor
6660         msglen=msglen1
6661         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6662 cd      write (iout,*) 'Processor',MyID,
6663 cd   & ' is receiving correlation contribution from processor',MyID+1,
6664 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6665 cd      write (*,*) 'Processor',MyID,
6666 cd   & ' is receiving correlation contribution from processor',MyID+1,
6667 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6668         nbytes=-1
6669         do while (nbytes.le.0)
6670           call mp_probe(MyID+1,CorrelType,nbytes)
6671         enddo
6672 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6673         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6674 cd      write (iout,*) 'Processor',MyID,
6675 cd   & ' has received correlation contribution from processor',MyID+1,
6676 cd   & ' msglen=',msglen,' nbytes=',nbytes
6677 cd      write (iout,*) 'The received BUFFER array:'
6678 cd      do i=1,max_cont
6679 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6680 cd      enddo
6681         if (msglen.eq.msglen1) then
6682           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6683         else if (msglen.eq.msglen2)  then
6684           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6685           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6686         else
6687           write (iout,*)
6688      & 'ERROR!!!! message length changed while processing correlations.'
6689           write (*,*)
6690      & 'ERROR!!!! message length changed while processing correlations.'
6691           call mp_stopall(Error)
6692         endif ! msglen.eq.msglen1
6693       endif ! MyRank.lt.fgProcs-1
6694       if (ldone) goto 30
6695       ldone=.true.
6696       goto 10
6697    30 continue
6698 #endif
6699       if (lprn) then
6700         write (iout,'(a)') 'Contact function values:'
6701         do i=nnt,nct-2
6702           write (iout,'(2i3,50(1x,i2,f5.2))')
6703      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6704      &    j=1,num_cont_hb(i))
6705         enddo
6706       endif
6707       ecorr=0.0D0
6708       ecorr5=0.0d0
6709       ecorr6=0.0d0
6710 C Remove the loop below after debugging !!!
6711       do i=nnt,nct
6712         do j=1,3
6713           gradcorr(j,i)=0.0D0
6714           gradxorr(j,i)=0.0D0
6715         enddo
6716       enddo
6717 C Calculate the dipole-dipole interaction energies
6718       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6719       do i=iatel_s,iatel_e+1
6720         num_conti=num_cont_hb(i)
6721         do jj=1,num_conti
6722           j=jcont_hb(jj,i)
6723           call dipole(i,j,jj)
6724         enddo
6725       enddo
6726       endif
6727 C Calculate the local-electrostatic correlation terms
6728       do i=iatel_s,iatel_e+1
6729         i1=i+1
6730         num_conti=num_cont_hb(i)
6731         num_conti1=num_cont_hb(i+1)
6732         do jj=1,num_conti
6733           j=jcont_hb(jj,i)
6734           do kk=1,num_conti1
6735             j1=jcont_hb(kk,i1)
6736 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6737 c     &         ' jj=',jj,' kk=',kk
6738             if (j1.eq.j+1 .or. j1.eq.j-1) then
6739 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6740 C The system gains extra energy.
6741               n_corr=n_corr+1
6742               sqd1=dsqrt(d_cont(jj,i))
6743               sqd2=dsqrt(d_cont(kk,i1))
6744               sred_geom = sqd1*sqd2
6745               IF (sred_geom.lt.cutoff_corr) THEN
6746                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6747      &            ekont,fprimcont)
6748 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6749 c     &         ' jj=',jj,' kk=',kk
6750                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6751                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6752                 do l=1,3
6753                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6754                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6755                 enddo
6756                 n_corr1=n_corr1+1
6757 cd               write (iout,*) 'sred_geom=',sred_geom,
6758 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6759                 call calc_eello(i,j,i+1,j1,jj,kk)
6760                 if (wcorr4.gt.0.0d0)
6761      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6762                 if (wcorr5.gt.0.0d0)
6763      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6764 c                print *,"wcorr5",ecorr5
6765 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6766 cd                write(2,*)'ijkl',i,j,i+1,j1
6767                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6768      &               .or. wturn6.eq.0.0d0))then
6769 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6770                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6771 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6772 cd     &            'ecorr6=',ecorr6
6773 cd                write (iout,'(4e15.5)') sred_geom,
6774 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6775 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6776 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6777                 else if (wturn6.gt.0.0d0
6778      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6779 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6780                   eturn6=eturn6+eello_turn6(i,jj,kk)
6781 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6782                 endif
6783               ENDIF
6784 1111          continue
6785             else if (j1.eq.j) then
6786 C Contacts I-J and I-(J+1) occur simultaneously.
6787 C The system loses extra energy.
6788 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6789             endif
6790           enddo ! kk
6791           do kk=1,num_conti
6792             j1=jcont_hb(kk,i)
6793 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6794 c    &         ' jj=',jj,' kk=',kk
6795             if (j1.eq.j+1) then
6796 C Contacts I-J and (I+1)-J occur simultaneously.
6797 C The system loses extra energy.
6798 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6799             endif ! j1==j+1
6800           enddo ! kk
6801         enddo ! jj
6802       enddo ! i
6803       return
6804       end
6805 c------------------------------------------------------------------------------
6806       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6807       implicit real*8 (a-h,o-z)
6808       include 'DIMENSIONS'
6809       include 'COMMON.IOUNITS'
6810       include 'COMMON.DERIV'
6811       include 'COMMON.INTERACT'
6812       include 'COMMON.CONTACTS'
6813       double precision gx(3),gx1(3)
6814       logical lprn
6815       lprn=.false.
6816       eij=facont_hb(jj,i)
6817       ekl=facont_hb(kk,k)
6818       ees0pij=ees0p(jj,i)
6819       ees0pkl=ees0p(kk,k)
6820       ees0mij=ees0m(jj,i)
6821       ees0mkl=ees0m(kk,k)
6822       ekont=eij*ekl
6823       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6824 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6825 C Following 4 lines for diagnostics.
6826 cd    ees0pkl=0.0D0
6827 cd    ees0pij=1.0D0
6828 cd    ees0mkl=0.0D0
6829 cd    ees0mij=1.0D0
6830 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6831 c    &   ' and',k,l
6832 c     write (iout,*)'Contacts have occurred for peptide groups',
6833 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6834 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6835 C Calculate the multi-body contribution to energy.
6836       ecorr=ecorr+ekont*ees
6837       if (calc_grad) then
6838 C Calculate multi-body contributions to the gradient.
6839       do ll=1,3
6840         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6841         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6842      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6843      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6844         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6845      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6846      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6847         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6848         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6849      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6850      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6851         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6852      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6853      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6854       enddo
6855       do m=i+1,j-1
6856         do ll=1,3
6857           gradcorr(ll,m)=gradcorr(ll,m)+
6858      &     ees*ekl*gacont_hbr(ll,jj,i)-
6859      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6860      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6861         enddo
6862       enddo
6863       do m=k+1,l-1
6864         do ll=1,3
6865           gradcorr(ll,m)=gradcorr(ll,m)+
6866      &     ees*eij*gacont_hbr(ll,kk,k)-
6867      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6868      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6869         enddo
6870       enddo
6871       endif
6872       ehbcorr=ekont*ees
6873       return
6874       end
6875 C---------------------------------------------------------------------------
6876       subroutine dipole(i,j,jj)
6877       implicit real*8 (a-h,o-z)
6878       include 'DIMENSIONS'
6879       include 'sizesclu.dat'
6880       include 'COMMON.IOUNITS'
6881       include 'COMMON.CHAIN'
6882       include 'COMMON.FFIELD'
6883       include 'COMMON.DERIV'
6884       include 'COMMON.INTERACT'
6885       include 'COMMON.CONTACTS'
6886       include 'COMMON.TORSION'
6887       include 'COMMON.VAR'
6888       include 'COMMON.GEO'
6889       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6890      &  auxmat(2,2)
6891       iti1 = itortyp(itype(i+1))
6892       if (j.lt.nres-1) then
6893         itj1 = itortyp(itype(j+1))
6894       else
6895         itj1=ntortyp+1
6896       endif
6897       do iii=1,2
6898         dipi(iii,1)=Ub2(iii,i)
6899         dipderi(iii)=Ub2der(iii,i)
6900         dipi(iii,2)=b1(iii,iti1)
6901         dipj(iii,1)=Ub2(iii,j)
6902         dipderj(iii)=Ub2der(iii,j)
6903         dipj(iii,2)=b1(iii,itj1)
6904       enddo
6905       kkk=0
6906       do iii=1,2
6907         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6908         do jjj=1,2
6909           kkk=kkk+1
6910           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6911         enddo
6912       enddo
6913       if (.not.calc_grad) return
6914       do kkk=1,5
6915         do lll=1,3
6916           mmm=0
6917           do iii=1,2
6918             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6919      &        auxvec(1))
6920             do jjj=1,2
6921               mmm=mmm+1
6922               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6923             enddo
6924           enddo
6925         enddo
6926       enddo
6927       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6928       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6929       do iii=1,2
6930         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6931       enddo
6932       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6933       do iii=1,2
6934         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6935       enddo
6936       return
6937       end
6938 C---------------------------------------------------------------------------
6939       subroutine calc_eello(i,j,k,l,jj,kk)
6940 C
6941 C This subroutine computes matrices and vectors needed to calculate
6942 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6943 C
6944       implicit real*8 (a-h,o-z)
6945       include 'DIMENSIONS'
6946       include 'sizesclu.dat'
6947       include 'COMMON.IOUNITS'
6948       include 'COMMON.CHAIN'
6949       include 'COMMON.DERIV'
6950       include 'COMMON.INTERACT'
6951       include 'COMMON.CONTACTS'
6952       include 'COMMON.TORSION'
6953       include 'COMMON.VAR'
6954       include 'COMMON.GEO'
6955       include 'COMMON.FFIELD'
6956       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6957      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6958       logical lprn
6959       common /kutas/ lprn
6960 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6961 cd     & ' jj=',jj,' kk=',kk
6962 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6963       do iii=1,2
6964         do jjj=1,2
6965           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6966           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6967         enddo
6968       enddo
6969       call transpose2(aa1(1,1),aa1t(1,1))
6970       call transpose2(aa2(1,1),aa2t(1,1))
6971       do kkk=1,5
6972         do lll=1,3
6973           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6974      &      aa1tder(1,1,lll,kkk))
6975           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6976      &      aa2tder(1,1,lll,kkk))
6977         enddo
6978       enddo
6979       if (l.eq.j+1) then
6980 C parallel orientation of the two CA-CA-CA frames.
6981         if (i.gt.1) then
6982           iti=itortyp(itype(i))
6983         else
6984           iti=ntortyp+1
6985         endif
6986         itk1=itortyp(itype(k+1))
6987         itj=itortyp(itype(j))
6988         if (l.lt.nres-1) then
6989           itl1=itortyp(itype(l+1))
6990         else
6991           itl1=ntortyp+1
6992         endif
6993 C A1 kernel(j+1) A2T
6994 cd        do iii=1,2
6995 cd          write (iout,'(3f10.5,5x,3f10.5)')
6996 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6997 cd        enddo
6998         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6999      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7000      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7001 C Following matrices are needed only for 6-th order cumulants
7002         IF (wcorr6.gt.0.0d0) THEN
7003         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7004      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7005      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7006         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7007      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7008      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7009      &   ADtEAderx(1,1,1,1,1,1))
7010         lprn=.false.
7011         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7012      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7013      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7014      &   ADtEA1derx(1,1,1,1,1,1))
7015         ENDIF
7016 C End 6-th order cumulants
7017 cd        lprn=.false.
7018 cd        if (lprn) then
7019 cd        write (2,*) 'In calc_eello6'
7020 cd        do iii=1,2
7021 cd          write (2,*) 'iii=',iii
7022 cd          do kkk=1,5
7023 cd            write (2,*) 'kkk=',kkk
7024 cd            do jjj=1,2
7025 cd              write (2,'(3(2f10.5),5x)')
7026 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7027 cd            enddo
7028 cd          enddo
7029 cd        enddo
7030 cd        endif
7031         call transpose2(EUgder(1,1,k),auxmat(1,1))
7032         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7033         call transpose2(EUg(1,1,k),auxmat(1,1))
7034         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7035         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7036         do iii=1,2
7037           do kkk=1,5
7038             do lll=1,3
7039               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7040      &          EAEAderx(1,1,lll,kkk,iii,1))
7041             enddo
7042           enddo
7043         enddo
7044 C A1T kernel(i+1) A2
7045         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7046      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7047      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7048 C Following matrices are needed only for 6-th order cumulants
7049         IF (wcorr6.gt.0.0d0) THEN
7050         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7051      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7052      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7053         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7054      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7055      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7056      &   ADtEAderx(1,1,1,1,1,2))
7057         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7058      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7059      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7060      &   ADtEA1derx(1,1,1,1,1,2))
7061         ENDIF
7062 C End 6-th order cumulants
7063         call transpose2(EUgder(1,1,l),auxmat(1,1))
7064         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7065         call transpose2(EUg(1,1,l),auxmat(1,1))
7066         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7067         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7068         do iii=1,2
7069           do kkk=1,5
7070             do lll=1,3
7071               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7072      &          EAEAderx(1,1,lll,kkk,iii,2))
7073             enddo
7074           enddo
7075         enddo
7076 C AEAb1 and AEAb2
7077 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7078 C They are needed only when the fifth- or the sixth-order cumulants are
7079 C indluded.
7080         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7081         call transpose2(AEA(1,1,1),auxmat(1,1))
7082         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7083         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7084         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7085         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7086         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7087         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7088         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7089         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7090         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7091         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7092         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7093         call transpose2(AEA(1,1,2),auxmat(1,1))
7094         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7095         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7096         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7097         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7098         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7099         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7100         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7101         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7102         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7103         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7104         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7105 C Calculate the Cartesian derivatives of the vectors.
7106         do iii=1,2
7107           do kkk=1,5
7108             do lll=1,3
7109               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7110               call matvec2(auxmat(1,1),b1(1,iti),
7111      &          AEAb1derx(1,lll,kkk,iii,1,1))
7112               call matvec2(auxmat(1,1),Ub2(1,i),
7113      &          AEAb2derx(1,lll,kkk,iii,1,1))
7114               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7115      &          AEAb1derx(1,lll,kkk,iii,2,1))
7116               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7117      &          AEAb2derx(1,lll,kkk,iii,2,1))
7118               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7119               call matvec2(auxmat(1,1),b1(1,itj),
7120      &          AEAb1derx(1,lll,kkk,iii,1,2))
7121               call matvec2(auxmat(1,1),Ub2(1,j),
7122      &          AEAb2derx(1,lll,kkk,iii,1,2))
7123               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7124      &          AEAb1derx(1,lll,kkk,iii,2,2))
7125               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7126      &          AEAb2derx(1,lll,kkk,iii,2,2))
7127             enddo
7128           enddo
7129         enddo
7130         ENDIF
7131 C End vectors
7132       else
7133 C Antiparallel orientation of the two CA-CA-CA frames.
7134         if (i.gt.1) then
7135           iti=itortyp(itype(i))
7136         else
7137           iti=ntortyp+1
7138         endif
7139         itk1=itortyp(itype(k+1))
7140         itl=itortyp(itype(l))
7141         itj=itortyp(itype(j))
7142         if (j.lt.nres-1) then
7143           itj1=itortyp(itype(j+1))
7144         else
7145           itj1=ntortyp+1
7146         endif
7147 C A2 kernel(j-1)T A1T
7148         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7149      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7150      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7151 C Following matrices are needed only for 6-th order cumulants
7152         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7153      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7154         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7155      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7156      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7157         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7158      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7159      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7160      &   ADtEAderx(1,1,1,1,1,1))
7161         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7162      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7163      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7164      &   ADtEA1derx(1,1,1,1,1,1))
7165         ENDIF
7166 C End 6-th order cumulants
7167         call transpose2(EUgder(1,1,k),auxmat(1,1))
7168         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7169         call transpose2(EUg(1,1,k),auxmat(1,1))
7170         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7171         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7172         do iii=1,2
7173           do kkk=1,5
7174             do lll=1,3
7175               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7176      &          EAEAderx(1,1,lll,kkk,iii,1))
7177             enddo
7178           enddo
7179         enddo
7180 C A2T kernel(i+1)T A1
7181         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7182      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7183      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7184 C Following matrices are needed only for 6-th order cumulants
7185         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7186      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7187         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7188      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7189      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7190         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7191      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7192      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7193      &   ADtEAderx(1,1,1,1,1,2))
7194         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7195      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7196      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7197      &   ADtEA1derx(1,1,1,1,1,2))
7198         ENDIF
7199 C End 6-th order cumulants
7200         call transpose2(EUgder(1,1,j),auxmat(1,1))
7201         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7202         call transpose2(EUg(1,1,j),auxmat(1,1))
7203         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7204         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7205         do iii=1,2
7206           do kkk=1,5
7207             do lll=1,3
7208               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7209      &          EAEAderx(1,1,lll,kkk,iii,2))
7210             enddo
7211           enddo
7212         enddo
7213 C AEAb1 and AEAb2
7214 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7215 C They are needed only when the fifth- or the sixth-order cumulants are
7216 C indluded.
7217         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7218      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7219         call transpose2(AEA(1,1,1),auxmat(1,1))
7220         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7221         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7222         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7223         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7224         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7225         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7226         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7227         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7228         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7229         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7230         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7231         call transpose2(AEA(1,1,2),auxmat(1,1))
7232         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7233         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7234         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7235         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7236         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7237         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7238         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7239         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7240         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7241         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7242         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7243 C Calculate the Cartesian derivatives of the vectors.
7244         do iii=1,2
7245           do kkk=1,5
7246             do lll=1,3
7247               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7248               call matvec2(auxmat(1,1),b1(1,iti),
7249      &          AEAb1derx(1,lll,kkk,iii,1,1))
7250               call matvec2(auxmat(1,1),Ub2(1,i),
7251      &          AEAb2derx(1,lll,kkk,iii,1,1))
7252               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7253      &          AEAb1derx(1,lll,kkk,iii,2,1))
7254               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7255      &          AEAb2derx(1,lll,kkk,iii,2,1))
7256               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7257               call matvec2(auxmat(1,1),b1(1,itl),
7258      &          AEAb1derx(1,lll,kkk,iii,1,2))
7259               call matvec2(auxmat(1,1),Ub2(1,l),
7260      &          AEAb2derx(1,lll,kkk,iii,1,2))
7261               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7262      &          AEAb1derx(1,lll,kkk,iii,2,2))
7263               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7264      &          AEAb2derx(1,lll,kkk,iii,2,2))
7265             enddo
7266           enddo
7267         enddo
7268         ENDIF
7269 C End vectors
7270       endif
7271       return
7272       end
7273 C---------------------------------------------------------------------------
7274       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7275      &  KK,KKderg,AKA,AKAderg,AKAderx)
7276       implicit none
7277       integer nderg
7278       logical transp
7279       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7280      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7281      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7282       integer iii,kkk,lll
7283       integer jjj,mmm
7284       logical lprn
7285       common /kutas/ lprn
7286       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7287       do iii=1,nderg
7288         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7289      &    AKAderg(1,1,iii))
7290       enddo
7291 cd      if (lprn) write (2,*) 'In kernel'
7292       do kkk=1,5
7293 cd        if (lprn) write (2,*) 'kkk=',kkk
7294         do lll=1,3
7295           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7296      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7297 cd          if (lprn) then
7298 cd            write (2,*) 'lll=',lll
7299 cd            write (2,*) 'iii=1'
7300 cd            do jjj=1,2
7301 cd              write (2,'(3(2f10.5),5x)')
7302 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7303 cd            enddo
7304 cd          endif
7305           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7306      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7307 cd          if (lprn) then
7308 cd            write (2,*) 'lll=',lll
7309 cd            write (2,*) 'iii=2'
7310 cd            do jjj=1,2
7311 cd              write (2,'(3(2f10.5),5x)')
7312 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7313 cd            enddo
7314 cd          endif
7315         enddo
7316       enddo
7317       return
7318       end
7319 C---------------------------------------------------------------------------
7320       double precision function eello4(i,j,k,l,jj,kk)
7321       implicit real*8 (a-h,o-z)
7322       include 'DIMENSIONS'
7323       include 'sizesclu.dat'
7324       include 'COMMON.IOUNITS'
7325       include 'COMMON.CHAIN'
7326       include 'COMMON.DERIV'
7327       include 'COMMON.INTERACT'
7328       include 'COMMON.CONTACTS'
7329       include 'COMMON.TORSION'
7330       include 'COMMON.VAR'
7331       include 'COMMON.GEO'
7332       double precision pizda(2,2),ggg1(3),ggg2(3)
7333 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7334 cd        eello4=0.0d0
7335 cd        return
7336 cd      endif
7337 cd      print *,'eello4:',i,j,k,l,jj,kk
7338 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7339 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7340 cold      eij=facont_hb(jj,i)
7341 cold      ekl=facont_hb(kk,k)
7342 cold      ekont=eij*ekl
7343       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7344       if (calc_grad) then
7345 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7346       gcorr_loc(k-1)=gcorr_loc(k-1)
7347      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7348       if (l.eq.j+1) then
7349         gcorr_loc(l-1)=gcorr_loc(l-1)
7350      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7351       else
7352         gcorr_loc(j-1)=gcorr_loc(j-1)
7353      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7354       endif
7355       do iii=1,2
7356         do kkk=1,5
7357           do lll=1,3
7358             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7359      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7360 cd            derx(lll,kkk,iii)=0.0d0
7361           enddo
7362         enddo
7363       enddo
7364 cd      gcorr_loc(l-1)=0.0d0
7365 cd      gcorr_loc(j-1)=0.0d0
7366 cd      gcorr_loc(k-1)=0.0d0
7367 cd      eel4=1.0d0
7368 cd      write (iout,*)'Contacts have occurred for peptide groups',
7369 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7370 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7371       if (j.lt.nres-1) then
7372         j1=j+1
7373         j2=j-1
7374       else
7375         j1=j-1
7376         j2=j-2
7377       endif
7378       if (l.lt.nres-1) then
7379         l1=l+1
7380         l2=l-1
7381       else
7382         l1=l-1
7383         l2=l-2
7384       endif
7385       do ll=1,3
7386 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
7387         ggg1(ll)=eel4*g_contij(ll,1)
7388         ggg2(ll)=eel4*g_contij(ll,2)
7389         ghalf=0.5d0*ggg1(ll)
7390 cd        ghalf=0.0d0
7391         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
7392         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7393         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
7394         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7395 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
7396         ghalf=0.5d0*ggg2(ll)
7397 cd        ghalf=0.0d0
7398         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
7399         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7400         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
7401         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7402       enddo
7403 cd      goto 1112
7404       do m=i+1,j-1
7405         do ll=1,3
7406 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
7407           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7408         enddo
7409       enddo
7410       do m=k+1,l-1
7411         do ll=1,3
7412 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
7413           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7414         enddo
7415       enddo
7416 1112  continue
7417       do m=i+2,j2
7418         do ll=1,3
7419           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7420         enddo
7421       enddo
7422       do m=k+2,l2
7423         do ll=1,3
7424           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7425         enddo
7426       enddo
7427 cd      do iii=1,nres-3
7428 cd        write (2,*) iii,gcorr_loc(iii)
7429 cd      enddo
7430       endif
7431       eello4=ekont*eel4
7432 cd      write (2,*) 'ekont',ekont
7433 cd      write (iout,*) 'eello4',ekont*eel4
7434       return
7435       end
7436 C---------------------------------------------------------------------------
7437       double precision function eello5(i,j,k,l,jj,kk)
7438       implicit real*8 (a-h,o-z)
7439       include 'DIMENSIONS'
7440       include 'sizesclu.dat'
7441       include 'COMMON.IOUNITS'
7442       include 'COMMON.CHAIN'
7443       include 'COMMON.DERIV'
7444       include 'COMMON.INTERACT'
7445       include 'COMMON.CONTACTS'
7446       include 'COMMON.TORSION'
7447       include 'COMMON.VAR'
7448       include 'COMMON.GEO'
7449       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7450       double precision ggg1(3),ggg2(3)
7451 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7452 C                                                                              C
7453 C                            Parallel chains                                   C
7454 C                                                                              C
7455 C          o             o                   o             o                   C
7456 C         /l\           / \             \   / \           / \   /              C
7457 C        /   \         /   \             \ /   \         /   \ /               C
7458 C       j| o |l1       | o |              o| o |         | o |o                C
7459 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7460 C      \i/   \         /   \ /             /   \         /   \                 C
7461 C       o    k1             o                                                  C
7462 C         (I)          (II)                (III)          (IV)                 C
7463 C                                                                              C
7464 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7465 C                                                                              C
7466 C                            Antiparallel chains                               C
7467 C                                                                              C
7468 C          o             o                   o             o                   C
7469 C         /j\           / \             \   / \           / \   /              C
7470 C        /   \         /   \             \ /   \         /   \ /               C
7471 C      j1| o |l        | o |              o| o |         | o |o                C
7472 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7473 C      \i/   \         /   \ /             /   \         /   \                 C
7474 C       o     k1            o                                                  C
7475 C         (I)          (II)                (III)          (IV)                 C
7476 C                                                                              C
7477 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7478 C                                                                              C
7479 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7480 C                                                                              C
7481 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7482 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7483 cd        eello5=0.0d0
7484 cd        return
7485 cd      endif
7486 cd      write (iout,*)
7487 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7488 cd     &   ' and',k,l
7489       itk=itortyp(itype(k))
7490       itl=itortyp(itype(l))
7491       itj=itortyp(itype(j))
7492       eello5_1=0.0d0
7493       eello5_2=0.0d0
7494       eello5_3=0.0d0
7495       eello5_4=0.0d0
7496 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7497 cd     &   eel5_3_num,eel5_4_num)
7498       do iii=1,2
7499         do kkk=1,5
7500           do lll=1,3
7501             derx(lll,kkk,iii)=0.0d0
7502           enddo
7503         enddo
7504       enddo
7505 cd      eij=facont_hb(jj,i)
7506 cd      ekl=facont_hb(kk,k)
7507 cd      ekont=eij*ekl
7508 cd      write (iout,*)'Contacts have occurred for peptide groups',
7509 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7510 cd      goto 1111
7511 C Contribution from the graph I.
7512 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7513 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7514       call transpose2(EUg(1,1,k),auxmat(1,1))
7515       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7516       vv(1)=pizda(1,1)-pizda(2,2)
7517       vv(2)=pizda(1,2)+pizda(2,1)
7518       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7519      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7520       if (calc_grad) then
7521 C Explicit gradient in virtual-dihedral angles.
7522       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7523      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7524      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7525       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7526       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7527       vv(1)=pizda(1,1)-pizda(2,2)
7528       vv(2)=pizda(1,2)+pizda(2,1)
7529       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7530      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7531      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7532       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7533       vv(1)=pizda(1,1)-pizda(2,2)
7534       vv(2)=pizda(1,2)+pizda(2,1)
7535       if (l.eq.j+1) then
7536         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7537      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7538      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7539       else
7540         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7541      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7542      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7543       endif
7544 C Cartesian gradient
7545       do iii=1,2
7546         do kkk=1,5
7547           do lll=1,3
7548             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7549      &        pizda(1,1))
7550             vv(1)=pizda(1,1)-pizda(2,2)
7551             vv(2)=pizda(1,2)+pizda(2,1)
7552             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7553      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7554      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7555           enddo
7556         enddo
7557       enddo
7558 c      goto 1112
7559       endif
7560 c1111  continue
7561 C Contribution from graph II
7562       call transpose2(EE(1,1,itk),auxmat(1,1))
7563       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7564       vv(1)=pizda(1,1)+pizda(2,2)
7565       vv(2)=pizda(2,1)-pizda(1,2)
7566       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7567      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7568       if (calc_grad) then
7569 C Explicit gradient in virtual-dihedral angles.
7570       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7571      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7572       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7573       vv(1)=pizda(1,1)+pizda(2,2)
7574       vv(2)=pizda(2,1)-pizda(1,2)
7575       if (l.eq.j+1) then
7576         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7577      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7578      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7579       else
7580         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7581      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7582      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7583       endif
7584 C Cartesian gradient
7585       do iii=1,2
7586         do kkk=1,5
7587           do lll=1,3
7588             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7589      &        pizda(1,1))
7590             vv(1)=pizda(1,1)+pizda(2,2)
7591             vv(2)=pizda(2,1)-pizda(1,2)
7592             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7593      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7594      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7595           enddo
7596         enddo
7597       enddo
7598 cd      goto 1112
7599       endif
7600 cd1111  continue
7601       if (l.eq.j+1) then
7602 cd        goto 1110
7603 C Parallel orientation
7604 C Contribution from graph III
7605         call transpose2(EUg(1,1,l),auxmat(1,1))
7606         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7607         vv(1)=pizda(1,1)-pizda(2,2)
7608         vv(2)=pizda(1,2)+pizda(2,1)
7609         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7610      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7611         if (calc_grad) then
7612 C Explicit gradient in virtual-dihedral angles.
7613         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7614      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7615      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7616         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7617         vv(1)=pizda(1,1)-pizda(2,2)
7618         vv(2)=pizda(1,2)+pizda(2,1)
7619         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7620      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7621      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7622         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7623         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7624         vv(1)=pizda(1,1)-pizda(2,2)
7625         vv(2)=pizda(1,2)+pizda(2,1)
7626         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7627      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7628      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7629 C Cartesian gradient
7630         do iii=1,2
7631           do kkk=1,5
7632             do lll=1,3
7633               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7634      &          pizda(1,1))
7635               vv(1)=pizda(1,1)-pizda(2,2)
7636               vv(2)=pizda(1,2)+pizda(2,1)
7637               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7638      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7639      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7640             enddo
7641           enddo
7642         enddo
7643 cd        goto 1112
7644         endif
7645 C Contribution from graph IV
7646 cd1110    continue
7647         call transpose2(EE(1,1,itl),auxmat(1,1))
7648         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7649         vv(1)=pizda(1,1)+pizda(2,2)
7650         vv(2)=pizda(2,1)-pizda(1,2)
7651         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7652      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7653         if (calc_grad) then
7654 C Explicit gradient in virtual-dihedral angles.
7655         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7656      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7657         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7658         vv(1)=pizda(1,1)+pizda(2,2)
7659         vv(2)=pizda(2,1)-pizda(1,2)
7660         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7661      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7662      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7663 C Cartesian gradient
7664         do iii=1,2
7665           do kkk=1,5
7666             do lll=1,3
7667               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7668      &          pizda(1,1))
7669               vv(1)=pizda(1,1)+pizda(2,2)
7670               vv(2)=pizda(2,1)-pizda(1,2)
7671               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7672      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7673      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7674             enddo
7675           enddo
7676         enddo
7677         endif
7678       else
7679 C Antiparallel orientation
7680 C Contribution from graph III
7681 c        goto 1110
7682         call transpose2(EUg(1,1,j),auxmat(1,1))
7683         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7684         vv(1)=pizda(1,1)-pizda(2,2)
7685         vv(2)=pizda(1,2)+pizda(2,1)
7686         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7687      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7688         if (calc_grad) then
7689 C Explicit gradient in virtual-dihedral angles.
7690         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7691      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7692      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7693         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7694         vv(1)=pizda(1,1)-pizda(2,2)
7695         vv(2)=pizda(1,2)+pizda(2,1)
7696         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7697      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7698      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7699         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7700         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7701         vv(1)=pizda(1,1)-pizda(2,2)
7702         vv(2)=pizda(1,2)+pizda(2,1)
7703         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7704      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7705      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7706 C Cartesian gradient
7707         do iii=1,2
7708           do kkk=1,5
7709             do lll=1,3
7710               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7711      &          pizda(1,1))
7712               vv(1)=pizda(1,1)-pizda(2,2)
7713               vv(2)=pizda(1,2)+pizda(2,1)
7714               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7715      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7716      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7717             enddo
7718           enddo
7719         enddo
7720 cd        goto 1112
7721         endif
7722 C Contribution from graph IV
7723 1110    continue
7724         call transpose2(EE(1,1,itj),auxmat(1,1))
7725         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7726         vv(1)=pizda(1,1)+pizda(2,2)
7727         vv(2)=pizda(2,1)-pizda(1,2)
7728         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7729      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7730         if (calc_grad) then
7731 C Explicit gradient in virtual-dihedral angles.
7732         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7733      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7734         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7735         vv(1)=pizda(1,1)+pizda(2,2)
7736         vv(2)=pizda(2,1)-pizda(1,2)
7737         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7738      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7739      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7740 C Cartesian gradient
7741         do iii=1,2
7742           do kkk=1,5
7743             do lll=1,3
7744               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7745      &          pizda(1,1))
7746               vv(1)=pizda(1,1)+pizda(2,2)
7747               vv(2)=pizda(2,1)-pizda(1,2)
7748               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7749      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7750      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7751             enddo
7752           enddo
7753         enddo
7754       endif
7755       endif
7756 1112  continue
7757       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7758 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7759 cd        write (2,*) 'ijkl',i,j,k,l
7760 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7761 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7762 cd      endif
7763 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7764 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7765 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7766 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7767       if (calc_grad) then
7768       if (j.lt.nres-1) then
7769         j1=j+1
7770         j2=j-1
7771       else
7772         j1=j-1
7773         j2=j-2
7774       endif
7775       if (l.lt.nres-1) then
7776         l1=l+1
7777         l2=l-1
7778       else
7779         l1=l-1
7780         l2=l-2
7781       endif
7782 cd      eij=1.0d0
7783 cd      ekl=1.0d0
7784 cd      ekont=1.0d0
7785 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7786       do ll=1,3
7787         ggg1(ll)=eel5*g_contij(ll,1)
7788         ggg2(ll)=eel5*g_contij(ll,2)
7789 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7790         ghalf=0.5d0*ggg1(ll)
7791 cd        ghalf=0.0d0
7792         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7793         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7794         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7795         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7796 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7797         ghalf=0.5d0*ggg2(ll)
7798 cd        ghalf=0.0d0
7799         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7800         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7801         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7802         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7803       enddo
7804 cd      goto 1112
7805       do m=i+1,j-1
7806         do ll=1,3
7807 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7808           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7809         enddo
7810       enddo
7811       do m=k+1,l-1
7812         do ll=1,3
7813 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7814           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7815         enddo
7816       enddo
7817 c1112  continue
7818       do m=i+2,j2
7819         do ll=1,3
7820           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7821         enddo
7822       enddo
7823       do m=k+2,l2
7824         do ll=1,3
7825           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7826         enddo
7827       enddo
7828 cd      do iii=1,nres-3
7829 cd        write (2,*) iii,g_corr5_loc(iii)
7830 cd      enddo
7831       endif
7832       eello5=ekont*eel5
7833 cd      write (2,*) 'ekont',ekont
7834 cd      write (iout,*) 'eello5',ekont*eel5
7835       return
7836       end
7837 c--------------------------------------------------------------------------
7838       double precision function eello6(i,j,k,l,jj,kk)
7839       implicit real*8 (a-h,o-z)
7840       include 'DIMENSIONS'
7841       include 'sizesclu.dat'
7842       include 'COMMON.IOUNITS'
7843       include 'COMMON.CHAIN'
7844       include 'COMMON.DERIV'
7845       include 'COMMON.INTERACT'
7846       include 'COMMON.CONTACTS'
7847       include 'COMMON.TORSION'
7848       include 'COMMON.VAR'
7849       include 'COMMON.GEO'
7850       include 'COMMON.FFIELD'
7851       double precision ggg1(3),ggg2(3)
7852 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7853 cd        eello6=0.0d0
7854 cd        return
7855 cd      endif
7856 cd      write (iout,*)
7857 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7858 cd     &   ' and',k,l
7859       eello6_1=0.0d0
7860       eello6_2=0.0d0
7861       eello6_3=0.0d0
7862       eello6_4=0.0d0
7863       eello6_5=0.0d0
7864       eello6_6=0.0d0
7865 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7866 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7867       do iii=1,2
7868         do kkk=1,5
7869           do lll=1,3
7870             derx(lll,kkk,iii)=0.0d0
7871           enddo
7872         enddo
7873       enddo
7874 cd      eij=facont_hb(jj,i)
7875 cd      ekl=facont_hb(kk,k)
7876 cd      ekont=eij*ekl
7877 cd      eij=1.0d0
7878 cd      ekl=1.0d0
7879 cd      ekont=1.0d0
7880       if (l.eq.j+1) then
7881         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7882         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7883         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7884         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7885         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7886         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7887       else
7888         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7889         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7890         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7891         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7892         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7893           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7894         else
7895           eello6_5=0.0d0
7896         endif
7897         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7898       endif
7899 C If turn contributions are considered, they will be handled separately.
7900       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7901 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7902 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7903 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7904 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7905 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7906 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7907 cd      goto 1112
7908       if (calc_grad) then
7909       if (j.lt.nres-1) then
7910         j1=j+1
7911         j2=j-1
7912       else
7913         j1=j-1
7914         j2=j-2
7915       endif
7916       if (l.lt.nres-1) then
7917         l1=l+1
7918         l2=l-1
7919       else
7920         l1=l-1
7921         l2=l-2
7922       endif
7923       do ll=1,3
7924         ggg1(ll)=eel6*g_contij(ll,1)
7925         ggg2(ll)=eel6*g_contij(ll,2)
7926 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7927         ghalf=0.5d0*ggg1(ll)
7928 cd        ghalf=0.0d0
7929         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7930         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7931         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7932         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7933         ghalf=0.5d0*ggg2(ll)
7934 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7935 cd        ghalf=0.0d0
7936         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7937         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7938         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7939         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7940       enddo
7941 cd      goto 1112
7942       do m=i+1,j-1
7943         do ll=1,3
7944 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7945           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7946         enddo
7947       enddo
7948       do m=k+1,l-1
7949         do ll=1,3
7950 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7951           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7952         enddo
7953       enddo
7954 1112  continue
7955       do m=i+2,j2
7956         do ll=1,3
7957           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7958         enddo
7959       enddo
7960       do m=k+2,l2
7961         do ll=1,3
7962           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7963         enddo
7964       enddo
7965 cd      do iii=1,nres-3
7966 cd        write (2,*) iii,g_corr6_loc(iii)
7967 cd      enddo
7968       endif
7969       eello6=ekont*eel6
7970 cd      write (2,*) 'ekont',ekont
7971 cd      write (iout,*) 'eello6',ekont*eel6
7972       return
7973       end
7974 c--------------------------------------------------------------------------
7975       double precision function eello6_graph1(i,j,k,l,imat,swap)
7976       implicit real*8 (a-h,o-z)
7977       include 'DIMENSIONS'
7978       include 'sizesclu.dat'
7979       include 'COMMON.IOUNITS'
7980       include 'COMMON.CHAIN'
7981       include 'COMMON.DERIV'
7982       include 'COMMON.INTERACT'
7983       include 'COMMON.CONTACTS'
7984       include 'COMMON.TORSION'
7985       include 'COMMON.VAR'
7986       include 'COMMON.GEO'
7987       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7988       logical swap
7989       logical lprn
7990       common /kutas/ lprn
7991 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7992 C                                                                              C
7993 C      Parallel       Antiparallel                                             C
7994 C                                                                              C
7995 C          o             o                                                     C
7996 C         /l\           /j\                                                    C
7997 C        /   \         /   \                                                   C
7998 C       /| o |         | o |\                                                  C
7999 C     \ j|/k\|  /   \  |/k\|l /                                                C
8000 C      \ /   \ /     \ /   \ /                                                 C
8001 C       o     o       o     o                                                  C
8002 C       i             i                                                        C
8003 C                                                                              C
8004 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8005       itk=itortyp(itype(k))
8006       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8007       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8008       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8009       call transpose2(EUgC(1,1,k),auxmat(1,1))
8010       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8011       vv1(1)=pizda1(1,1)-pizda1(2,2)
8012       vv1(2)=pizda1(1,2)+pizda1(2,1)
8013       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8014       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8015       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8016       s5=scalar2(vv(1),Dtobr2(1,i))
8017 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8018       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8019       if (.not. calc_grad) return
8020       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8021      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8022      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8023      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8024      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8025      & +scalar2(vv(1),Dtobr2der(1,i)))
8026       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8027       vv1(1)=pizda1(1,1)-pizda1(2,2)
8028       vv1(2)=pizda1(1,2)+pizda1(2,1)
8029       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8030       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8031       if (l.eq.j+1) then
8032         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8033      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8034      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8035      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8036      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8037       else
8038         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8039      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8040      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8041      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8042      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8043       endif
8044       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8045       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8046       vv1(1)=pizda1(1,1)-pizda1(2,2)
8047       vv1(2)=pizda1(1,2)+pizda1(2,1)
8048       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8049      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8050      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8051      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8052       do iii=1,2
8053         if (swap) then
8054           ind=3-iii
8055         else
8056           ind=iii
8057         endif
8058         do kkk=1,5
8059           do lll=1,3
8060             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8061             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8062             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8063             call transpose2(EUgC(1,1,k),auxmat(1,1))
8064             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8065      &        pizda1(1,1))
8066             vv1(1)=pizda1(1,1)-pizda1(2,2)
8067             vv1(2)=pizda1(1,2)+pizda1(2,1)
8068             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8069             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8070      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8071             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8072      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8073             s5=scalar2(vv(1),Dtobr2(1,i))
8074             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8075           enddo
8076         enddo
8077       enddo
8078       return
8079       end
8080 c----------------------------------------------------------------------------
8081       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8082       implicit real*8 (a-h,o-z)
8083       include 'DIMENSIONS'
8084       include 'sizesclu.dat'
8085       include 'COMMON.IOUNITS'
8086       include 'COMMON.CHAIN'
8087       include 'COMMON.DERIV'
8088       include 'COMMON.INTERACT'
8089       include 'COMMON.CONTACTS'
8090       include 'COMMON.TORSION'
8091       include 'COMMON.VAR'
8092       include 'COMMON.GEO'
8093       logical swap
8094       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8095      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8096       logical lprn
8097       common /kutas/ lprn
8098 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8099 C                                                                              C
8100 C      Parallel       Antiparallel                                             C
8101 C                                                                              C
8102 C          o             o                                                     C
8103 C     \   /l\           /j\   /                                                C
8104 C      \ /   \         /   \ /                                                 C
8105 C       o| o |         | o |o                                                  C
8106 C     \ j|/k\|      \  |/k\|l                                                  C
8107 C      \ /   \       \ /   \                                                   C
8108 C       o             o                                                        C
8109 C       i             i                                                        C
8110 C                                                                              C
8111 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8112 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8113 C AL 7/4/01 s1 would occur in the sixth-order moment,
8114 C           but not in a cluster cumulant
8115 #ifdef MOMENT
8116       s1=dip(1,jj,i)*dip(1,kk,k)
8117 #endif
8118       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8119       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8120       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8121       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8122       call transpose2(EUg(1,1,k),auxmat(1,1))
8123       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8124       vv(1)=pizda(1,1)-pizda(2,2)
8125       vv(2)=pizda(1,2)+pizda(2,1)
8126       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8127 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8128 #ifdef MOMENT
8129       eello6_graph2=-(s1+s2+s3+s4)
8130 #else
8131       eello6_graph2=-(s2+s3+s4)
8132 #endif
8133 c      eello6_graph2=-s3
8134       if (.not. calc_grad) return
8135 C Derivatives in gamma(i-1)
8136       if (i.gt.1) then
8137 #ifdef MOMENT
8138         s1=dipderg(1,jj,i)*dip(1,kk,k)
8139 #endif
8140         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8141         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8142         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8143         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8144 #ifdef MOMENT
8145         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8146 #else
8147         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8148 #endif
8149 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8150       endif
8151 C Derivatives in gamma(k-1)
8152 #ifdef MOMENT
8153       s1=dip(1,jj,i)*dipderg(1,kk,k)
8154 #endif
8155       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8156       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8157       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8158       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8159       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8160       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8161       vv(1)=pizda(1,1)-pizda(2,2)
8162       vv(2)=pizda(1,2)+pizda(2,1)
8163       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8164 #ifdef MOMENT
8165       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8166 #else
8167       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8168 #endif
8169 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8170 C Derivatives in gamma(j-1) or gamma(l-1)
8171       if (j.gt.1) then
8172 #ifdef MOMENT
8173         s1=dipderg(3,jj,i)*dip(1,kk,k)
8174 #endif
8175         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8176         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8177         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8178         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8179         vv(1)=pizda(1,1)-pizda(2,2)
8180         vv(2)=pizda(1,2)+pizda(2,1)
8181         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8182 #ifdef MOMENT
8183         if (swap) then
8184           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8185         else
8186           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8187         endif
8188 #endif
8189         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8190 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8191       endif
8192 C Derivatives in gamma(l-1) or gamma(j-1)
8193       if (l.gt.1) then
8194 #ifdef MOMENT
8195         s1=dip(1,jj,i)*dipderg(3,kk,k)
8196 #endif
8197         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8198         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8199         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8200         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8201         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8202         vv(1)=pizda(1,1)-pizda(2,2)
8203         vv(2)=pizda(1,2)+pizda(2,1)
8204         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8205 #ifdef MOMENT
8206         if (swap) then
8207           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8208         else
8209           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8210         endif
8211 #endif
8212         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8213 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8214       endif
8215 C Cartesian derivatives.
8216       if (lprn) then
8217         write (2,*) 'In eello6_graph2'
8218         do iii=1,2
8219           write (2,*) 'iii=',iii
8220           do kkk=1,5
8221             write (2,*) 'kkk=',kkk
8222             do jjj=1,2
8223               write (2,'(3(2f10.5),5x)')
8224      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8225             enddo
8226           enddo
8227         enddo
8228       endif
8229       do iii=1,2
8230         do kkk=1,5
8231           do lll=1,3
8232 #ifdef MOMENT
8233             if (iii.eq.1) then
8234               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8235             else
8236               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8237             endif
8238 #endif
8239             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8240      &        auxvec(1))
8241             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8242             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8243      &        auxvec(1))
8244             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8245             call transpose2(EUg(1,1,k),auxmat(1,1))
8246             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8247      &        pizda(1,1))
8248             vv(1)=pizda(1,1)-pizda(2,2)
8249             vv(2)=pizda(1,2)+pizda(2,1)
8250             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8251 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8252 #ifdef MOMENT
8253             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8254 #else
8255             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8256 #endif
8257             if (swap) then
8258               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8259             else
8260               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8261             endif
8262           enddo
8263         enddo
8264       enddo
8265       return
8266       end
8267 c----------------------------------------------------------------------------
8268       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8269       implicit real*8 (a-h,o-z)
8270       include 'DIMENSIONS'
8271       include 'sizesclu.dat'
8272       include 'COMMON.IOUNITS'
8273       include 'COMMON.CHAIN'
8274       include 'COMMON.DERIV'
8275       include 'COMMON.INTERACT'
8276       include 'COMMON.CONTACTS'
8277       include 'COMMON.TORSION'
8278       include 'COMMON.VAR'
8279       include 'COMMON.GEO'
8280       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8281       logical swap
8282 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8283 C                                                                              C
8284 C      Parallel       Antiparallel                                             C
8285 C                                                                              C
8286 C          o             o                                                     C
8287 C         /l\   /   \   /j\                                                    C
8288 C        /   \ /     \ /   \                                                   C
8289 C       /| o |o       o| o |\                                                  C
8290 C       j|/k\|  /      |/k\|l /                                                C
8291 C        /   \ /       /   \ /                                                 C
8292 C       /     o       /     o                                                  C
8293 C       i             i                                                        C
8294 C                                                                              C
8295 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8296 C
8297 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8298 C           energy moment and not to the cluster cumulant.
8299       iti=itortyp(itype(i))
8300       if (j.lt.nres-1) then
8301         itj1=itortyp(itype(j+1))
8302       else
8303         itj1=ntortyp+1
8304       endif
8305       itk=itortyp(itype(k))
8306       itk1=itortyp(itype(k+1))
8307       if (l.lt.nres-1) then
8308         itl1=itortyp(itype(l+1))
8309       else
8310         itl1=ntortyp+1
8311       endif
8312 #ifdef MOMENT
8313       s1=dip(4,jj,i)*dip(4,kk,k)
8314 #endif
8315       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8316       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8317       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8318       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8319       call transpose2(EE(1,1,itk),auxmat(1,1))
8320       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8321       vv(1)=pizda(1,1)+pizda(2,2)
8322       vv(2)=pizda(2,1)-pizda(1,2)
8323       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8324 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8325 #ifdef MOMENT
8326       eello6_graph3=-(s1+s2+s3+s4)
8327 #else
8328       eello6_graph3=-(s2+s3+s4)
8329 #endif
8330 c      eello6_graph3=-s4
8331       if (.not. calc_grad) return
8332 C Derivatives in gamma(k-1)
8333       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8334       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8335       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8336       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8337 C Derivatives in gamma(l-1)
8338       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8339       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8340       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8341       vv(1)=pizda(1,1)+pizda(2,2)
8342       vv(2)=pizda(2,1)-pizda(1,2)
8343       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8344       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8345 C Cartesian derivatives.
8346       do iii=1,2
8347         do kkk=1,5
8348           do lll=1,3
8349 #ifdef MOMENT
8350             if (iii.eq.1) then
8351               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8352             else
8353               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8354             endif
8355 #endif
8356             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8357      &        auxvec(1))
8358             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8359             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8360      &        auxvec(1))
8361             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8362             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8363      &        pizda(1,1))
8364             vv(1)=pizda(1,1)+pizda(2,2)
8365             vv(2)=pizda(2,1)-pizda(1,2)
8366             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8367 #ifdef MOMENT
8368             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8369 #else
8370             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8371 #endif
8372             if (swap) then
8373               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8374             else
8375               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8376             endif
8377 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8378           enddo
8379         enddo
8380       enddo
8381       return
8382       end
8383 c----------------------------------------------------------------------------
8384       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8385       implicit real*8 (a-h,o-z)
8386       include 'DIMENSIONS'
8387       include 'sizesclu.dat'
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       include 'COMMON.FFIELD'
8397       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8398      & auxvec1(2),auxmat1(2,2)
8399       logical swap
8400 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8401 C                                                                              C
8402 C      Parallel       Antiparallel                                             C
8403 C                                                                              C
8404 C          o             o                                                     C
8405 C         /l\   /   \   /j\                                                    C
8406 C        /   \ /     \ /   \                                                   C
8407 C       /| o |o       o| o |\                                                  C
8408 C     \ j|/k\|      \  |/k\|l                                                  C
8409 C      \ /   \       \ /   \                                                   C
8410 C       o     \       o     \                                                  C
8411 C       i             i                                                        C
8412 C                                                                              C
8413 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8414 C
8415 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8416 C           energy moment and not to the cluster cumulant.
8417 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8418       iti=itortyp(itype(i))
8419       itj=itortyp(itype(j))
8420       if (j.lt.nres-1) then
8421         itj1=itortyp(itype(j+1))
8422       else
8423         itj1=ntortyp+1
8424       endif
8425       itk=itortyp(itype(k))
8426       if (k.lt.nres-1) then
8427         itk1=itortyp(itype(k+1))
8428       else
8429         itk1=ntortyp+1
8430       endif
8431       itl=itortyp(itype(l))
8432       if (l.lt.nres-1) then
8433         itl1=itortyp(itype(l+1))
8434       else
8435         itl1=ntortyp+1
8436       endif
8437 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8438 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8439 cd     & ' itl',itl,' itl1',itl1
8440 #ifdef MOMENT
8441       if (imat.eq.1) then
8442         s1=dip(3,jj,i)*dip(3,kk,k)
8443       else
8444         s1=dip(2,jj,j)*dip(2,kk,l)
8445       endif
8446 #endif
8447       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8448       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8449       if (j.eq.l+1) then
8450         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8451         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8452       else
8453         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8454         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8455       endif
8456       call transpose2(EUg(1,1,k),auxmat(1,1))
8457       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8458       vv(1)=pizda(1,1)-pizda(2,2)
8459       vv(2)=pizda(2,1)+pizda(1,2)
8460       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8461 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8462 #ifdef MOMENT
8463       eello6_graph4=-(s1+s2+s3+s4)
8464 #else
8465       eello6_graph4=-(s2+s3+s4)
8466 #endif
8467       if (.not. calc_grad) return
8468 C Derivatives in gamma(i-1)
8469       if (i.gt.1) then
8470 #ifdef MOMENT
8471         if (imat.eq.1) then
8472           s1=dipderg(2,jj,i)*dip(3,kk,k)
8473         else
8474           s1=dipderg(4,jj,j)*dip(2,kk,l)
8475         endif
8476 #endif
8477         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8478         if (j.eq.l+1) then
8479           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8480           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8481         else
8482           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8483           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8484         endif
8485         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8486         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8487 cd          write (2,*) 'turn6 derivatives'
8488 #ifdef MOMENT
8489           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8490 #else
8491           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8492 #endif
8493         else
8494 #ifdef MOMENT
8495           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8496 #else
8497           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8498 #endif
8499         endif
8500       endif
8501 C Derivatives in gamma(k-1)
8502 #ifdef MOMENT
8503       if (imat.eq.1) then
8504         s1=dip(3,jj,i)*dipderg(2,kk,k)
8505       else
8506         s1=dip(2,jj,j)*dipderg(4,kk,l)
8507       endif
8508 #endif
8509       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8510       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8511       if (j.eq.l+1) then
8512         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8513         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8514       else
8515         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8516         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8517       endif
8518       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8519       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8520       vv(1)=pizda(1,1)-pizda(2,2)
8521       vv(2)=pizda(2,1)+pizda(1,2)
8522       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8523       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8524 #ifdef MOMENT
8525         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8526 #else
8527         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8528 #endif
8529       else
8530 #ifdef MOMENT
8531         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8532 #else
8533         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8534 #endif
8535       endif
8536 C Derivatives in gamma(j-1) or gamma(l-1)
8537       if (l.eq.j+1 .and. l.gt.1) then
8538         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8539         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8540         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8541         vv(1)=pizda(1,1)-pizda(2,2)
8542         vv(2)=pizda(2,1)+pizda(1,2)
8543         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8544         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8545       else if (j.gt.1) then
8546         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8547         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8548         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8549         vv(1)=pizda(1,1)-pizda(2,2)
8550         vv(2)=pizda(2,1)+pizda(1,2)
8551         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8552         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8553           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8554         else
8555           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8556         endif
8557       endif
8558 C Cartesian derivatives.
8559       do iii=1,2
8560         do kkk=1,5
8561           do lll=1,3
8562 #ifdef MOMENT
8563             if (iii.eq.1) then
8564               if (imat.eq.1) then
8565                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8566               else
8567                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8568               endif
8569             else
8570               if (imat.eq.1) then
8571                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8572               else
8573                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8574               endif
8575             endif
8576 #endif
8577             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8578      &        auxvec(1))
8579             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8580             if (j.eq.l+1) then
8581               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8582      &          b1(1,itj1),auxvec(1))
8583               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8584             else
8585               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8586      &          b1(1,itl1),auxvec(1))
8587               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8588             endif
8589             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8590      &        pizda(1,1))
8591             vv(1)=pizda(1,1)-pizda(2,2)
8592             vv(2)=pizda(2,1)+pizda(1,2)
8593             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8594             if (swap) then
8595               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8596 #ifdef MOMENT
8597                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8598      &             -(s1+s2+s4)
8599 #else
8600                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8601      &             -(s2+s4)
8602 #endif
8603                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8604               else
8605 #ifdef MOMENT
8606                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8607 #else
8608                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8609 #endif
8610                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8611               endif
8612             else
8613 #ifdef MOMENT
8614               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8615 #else
8616               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8617 #endif
8618               if (l.eq.j+1) then
8619                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8620               else
8621                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8622               endif
8623             endif
8624           enddo
8625         enddo
8626       enddo
8627       return
8628       end
8629 c----------------------------------------------------------------------------
8630       double precision function eello_turn6(i,jj,kk)
8631       implicit real*8 (a-h,o-z)
8632       include 'DIMENSIONS'
8633       include 'sizesclu.dat'
8634       include 'COMMON.IOUNITS'
8635       include 'COMMON.CHAIN'
8636       include 'COMMON.DERIV'
8637       include 'COMMON.INTERACT'
8638       include 'COMMON.CONTACTS'
8639       include 'COMMON.TORSION'
8640       include 'COMMON.VAR'
8641       include 'COMMON.GEO'
8642       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8643      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8644      &  ggg1(3),ggg2(3)
8645       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8646      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8647 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8648 C           the respective energy moment and not to the cluster cumulant.
8649       eello_turn6=0.0d0
8650       j=i+4
8651       k=i+1
8652       l=i+3
8653       iti=itortyp(itype(i))
8654       itk=itortyp(itype(k))
8655       itk1=itortyp(itype(k+1))
8656       itl=itortyp(itype(l))
8657       itj=itortyp(itype(j))
8658 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8659 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8660 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8661 cd        eello6=0.0d0
8662 cd        return
8663 cd      endif
8664 cd      write (iout,*)
8665 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8666 cd     &   ' and',k,l
8667 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8668       do iii=1,2
8669         do kkk=1,5
8670           do lll=1,3
8671             derx_turn(lll,kkk,iii)=0.0d0
8672           enddo
8673         enddo
8674       enddo
8675 cd      eij=1.0d0
8676 cd      ekl=1.0d0
8677 cd      ekont=1.0d0
8678       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8679 cd      eello6_5=0.0d0
8680 cd      write (2,*) 'eello6_5',eello6_5
8681 #ifdef MOMENT
8682       call transpose2(AEA(1,1,1),auxmat(1,1))
8683       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8684       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8685       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8686 #else
8687       s1 = 0.0d0
8688 #endif
8689       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8690       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8691       s2 = scalar2(b1(1,itk),vtemp1(1))
8692 #ifdef MOMENT
8693       call transpose2(AEA(1,1,2),atemp(1,1))
8694       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8695       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8696       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8697 #else
8698       s8=0.0d0
8699 #endif
8700       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8701       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8702       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8703 #ifdef MOMENT
8704       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8705       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8706       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8707       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8708       ss13 = scalar2(b1(1,itk),vtemp4(1))
8709       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8710 #else
8711       s13=0.0d0
8712 #endif
8713 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8714 c      s1=0.0d0
8715 c      s2=0.0d0
8716 c      s8=0.0d0
8717 c      s12=0.0d0
8718 c      s13=0.0d0
8719       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8720       if (calc_grad) then
8721 C Derivatives in gamma(i+2)
8722 #ifdef MOMENT
8723       call transpose2(AEA(1,1,1),auxmatd(1,1))
8724       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8725       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8726       call transpose2(AEAderg(1,1,2),atempd(1,1))
8727       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8728       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8729 #else
8730       s8d=0.0d0
8731 #endif
8732       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8733       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8734       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8735 c      s1d=0.0d0
8736 c      s2d=0.0d0
8737 c      s8d=0.0d0
8738 c      s12d=0.0d0
8739 c      s13d=0.0d0
8740       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8741 C Derivatives in gamma(i+3)
8742 #ifdef MOMENT
8743       call transpose2(AEA(1,1,1),auxmatd(1,1))
8744       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8745       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8746       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8747 #else
8748       s1d=0.0d0
8749 #endif
8750       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8751       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8752       s2d = scalar2(b1(1,itk),vtemp1d(1))
8753 #ifdef MOMENT
8754       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8755       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8756 #endif
8757       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8758 #ifdef MOMENT
8759       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8760       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8761       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8762 #else
8763       s13d=0.0d0
8764 #endif
8765 c      s1d=0.0d0
8766 c      s2d=0.0d0
8767 c      s8d=0.0d0
8768 c      s12d=0.0d0
8769 c      s13d=0.0d0
8770 #ifdef MOMENT
8771       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8772      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8773 #else
8774       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8775      &               -0.5d0*ekont*(s2d+s12d)
8776 #endif
8777 C Derivatives in gamma(i+4)
8778       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8779       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8780       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8781 #ifdef MOMENT
8782       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8783       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8784       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8785 #else
8786       s13d = 0.0d0
8787 #endif
8788 c      s1d=0.0d0
8789 c      s2d=0.0d0
8790 c      s8d=0.0d0
8791 C      s12d=0.0d0
8792 c      s13d=0.0d0
8793 #ifdef MOMENT
8794       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8795 #else
8796       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8797 #endif
8798 C Derivatives in gamma(i+5)
8799 #ifdef MOMENT
8800       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8801       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8802       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8803 #else
8804       s1d = 0.0d0
8805 #endif
8806       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8807       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8808       s2d = scalar2(b1(1,itk),vtemp1d(1))
8809 #ifdef MOMENT
8810       call transpose2(AEA(1,1,2),atempd(1,1))
8811       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8812       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8813 #else
8814       s8d = 0.0d0
8815 #endif
8816       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8817       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8818 #ifdef MOMENT
8819       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8820       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8821       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8822 #else
8823       s13d = 0.0d0
8824 #endif
8825 c      s1d=0.0d0
8826 c      s2d=0.0d0
8827 c      s8d=0.0d0
8828 c      s12d=0.0d0
8829 c      s13d=0.0d0
8830 #ifdef MOMENT
8831       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8832      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8833 #else
8834       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8835      &               -0.5d0*ekont*(s2d+s12d)
8836 #endif
8837 C Cartesian derivatives
8838       do iii=1,2
8839         do kkk=1,5
8840           do lll=1,3
8841 #ifdef MOMENT
8842             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8843             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8844             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8845 #else
8846             s1d = 0.0d0
8847 #endif
8848             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8849             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8850      &          vtemp1d(1))
8851             s2d = scalar2(b1(1,itk),vtemp1d(1))
8852 #ifdef MOMENT
8853             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8854             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8855             s8d = -(atempd(1,1)+atempd(2,2))*
8856      &           scalar2(cc(1,1,itl),vtemp2(1))
8857 #else
8858             s8d = 0.0d0
8859 #endif
8860             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8861      &           auxmatd(1,1))
8862             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8863             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8864 c      s1d=0.0d0
8865 c      s2d=0.0d0
8866 c      s8d=0.0d0
8867 c      s12d=0.0d0
8868 c      s13d=0.0d0
8869 #ifdef MOMENT
8870             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8871      &        - 0.5d0*(s1d+s2d)
8872 #else
8873             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8874      &        - 0.5d0*s2d
8875 #endif
8876 #ifdef MOMENT
8877             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8878      &        - 0.5d0*(s8d+s12d)
8879 #else
8880             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8881      &        - 0.5d0*s12d
8882 #endif
8883           enddo
8884         enddo
8885       enddo
8886 #ifdef MOMENT
8887       do kkk=1,5
8888         do lll=1,3
8889           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8890      &      achuj_tempd(1,1))
8891           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8892           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8893           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8894           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8895           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8896      &      vtemp4d(1))
8897           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8898           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8899           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8900         enddo
8901       enddo
8902 #endif
8903 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8904 cd     &  16*eel_turn6_num
8905 cd      goto 1112
8906       if (j.lt.nres-1) then
8907         j1=j+1
8908         j2=j-1
8909       else
8910         j1=j-1
8911         j2=j-2
8912       endif
8913       if (l.lt.nres-1) then
8914         l1=l+1
8915         l2=l-1
8916       else
8917         l1=l-1
8918         l2=l-2
8919       endif
8920       do ll=1,3
8921         ggg1(ll)=eel_turn6*g_contij(ll,1)
8922         ggg2(ll)=eel_turn6*g_contij(ll,2)
8923         ghalf=0.5d0*ggg1(ll)
8924 cd        ghalf=0.0d0
8925         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8926      &    +ekont*derx_turn(ll,2,1)
8927         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8928         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8929      &    +ekont*derx_turn(ll,4,1)
8930         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8931         ghalf=0.5d0*ggg2(ll)
8932 cd        ghalf=0.0d0
8933         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8934      &    +ekont*derx_turn(ll,2,2)
8935         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8936         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8937      &    +ekont*derx_turn(ll,4,2)
8938         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8939       enddo
8940 cd      goto 1112
8941       do m=i+1,j-1
8942         do ll=1,3
8943           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8944         enddo
8945       enddo
8946       do m=k+1,l-1
8947         do ll=1,3
8948           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8949         enddo
8950       enddo
8951 1112  continue
8952       do m=i+2,j2
8953         do ll=1,3
8954           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8955         enddo
8956       enddo
8957       do m=k+2,l2
8958         do ll=1,3
8959           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8960         enddo
8961       enddo
8962 cd      do iii=1,nres-3
8963 cd        write (2,*) iii,g_corr6_loc(iii)
8964 cd      enddo
8965       endif
8966       eello_turn6=ekont*eel_turn6
8967 cd      write (2,*) 'ekont',ekont
8968 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8969       return
8970       end
8971 crc-------------------------------------------------
8972       SUBROUTINE MATVEC2(A1,V1,V2)
8973       implicit real*8 (a-h,o-z)
8974       include 'DIMENSIONS'
8975       DIMENSION A1(2,2),V1(2),V2(2)
8976 c      DO 1 I=1,2
8977 c        VI=0.0
8978 c        DO 3 K=1,2
8979 c    3     VI=VI+A1(I,K)*V1(K)
8980 c        Vaux(I)=VI
8981 c    1 CONTINUE
8982
8983       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8984       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8985
8986       v2(1)=vaux1
8987       v2(2)=vaux2
8988       END
8989 C---------------------------------------
8990       SUBROUTINE MATMAT2(A1,A2,A3)
8991       implicit real*8 (a-h,o-z)
8992       include 'DIMENSIONS'
8993       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8994 c      DIMENSION AI3(2,2)
8995 c        DO  J=1,2
8996 c          A3IJ=0.0
8997 c          DO K=1,2
8998 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8999 c          enddo
9000 c          A3(I,J)=A3IJ
9001 c       enddo
9002 c      enddo
9003
9004       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9005       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9006       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9007       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9008
9009       A3(1,1)=AI3_11
9010       A3(2,1)=AI3_21
9011       A3(1,2)=AI3_12
9012       A3(2,2)=AI3_22
9013       END
9014
9015 c-------------------------------------------------------------------------
9016       double precision function scalar2(u,v)
9017       implicit none
9018       double precision u(2),v(2)
9019       double precision sc
9020       integer i
9021       scalar2=u(1)*v(1)+u(2)*v(2)
9022       return
9023       end
9024
9025 C-----------------------------------------------------------------------------
9026
9027       subroutine transpose2(a,at)
9028       implicit none
9029       double precision a(2,2),at(2,2)
9030       at(1,1)=a(1,1)
9031       at(1,2)=a(2,1)
9032       at(2,1)=a(1,2)
9033       at(2,2)=a(2,2)
9034       return
9035       end
9036 c--------------------------------------------------------------------------
9037       subroutine transpose(n,a,at)
9038       implicit none
9039       integer n,i,j
9040       double precision a(n,n),at(n,n)
9041       do i=1,n
9042         do j=1,n
9043           at(j,i)=a(i,j)
9044         enddo
9045       enddo
9046       return
9047       end
9048 C---------------------------------------------------------------------------
9049       subroutine prodmat3(a1,a2,kk,transp,prod)
9050       implicit none
9051       integer i,j
9052       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9053       logical transp
9054 crc      double precision auxmat(2,2),prod_(2,2)
9055
9056       if (transp) then
9057 crc        call transpose2(kk(1,1),auxmat(1,1))
9058 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9059 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9060
9061            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9062      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9063            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9064      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9065            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9066      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9067            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9068      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9069
9070       else
9071 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9072 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9073
9074            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9075      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9076            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9077      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9078            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9079      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9080            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9081      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9082
9083       endif
9084 c      call transpose2(a2(1,1),a2t(1,1))
9085
9086 crc      print *,transp
9087 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9088 crc      print *,((prod(i,j),i=1,2),j=1,2)
9089
9090       return
9091       end
9092 C-----------------------------------------------------------------------------
9093       double precision function scalar(u,v)
9094       implicit none
9095       double precision u(3),v(3)
9096       double precision sc
9097       integer i
9098       sc=0.0d0
9099       do i=1,3
9100         sc=sc+u(i)*v(i)
9101       enddo
9102       scalar=sc
9103       return
9104       end
9105