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 #ifdef SCALREP
1089 ! Scale down the repulsive term for 1,4 interactions.
1090           if (iabs(j-i).le.4) c1  = 0.01d0 * c1
1091 #endif
1092 c!          c1        = 0.0d0
1093           c2        = fac  * bb(itypi,itypj)
1094 c!          c2        = 0.0d0
1095 c          write (2,*) "eps1",eps1," eps2rt",eps2rt," eps3rt",eps3rt,
1096 c     &     " c1",c1," c2",c2
1097           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
1098           eps2der   = eps3rt * evdwij
1099           eps3der   = eps2rt * evdwij
1100 c!          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
1101           evdwij    = eps2rt * eps3rt * evdwij
1102 c!      evdwij = 0.0d0
1103 c!      write (*,*) "Gey Berne = ", evdwij
1104 #ifdef TSCSC
1105           IF (bb(itypi,itypj).gt.0) THEN
1106            evdw_p = evdw_p + evdwij
1107           ELSE
1108            evdw_m = evdw_m + evdwij
1109           END IF
1110 #else
1111           evdw = evdw
1112      &         + evdwij
1113 #endif
1114 c!-------------------------------------------------------------------
1115 c! Calculate some components of GGB
1116           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
1117           fac    = -expon * (c1 + evdwij) * rij_shift
1118           sigder = fac * sigder
1119 c!          fac    = rij * fac
1120 c! Calculate distance derivative
1121 c!          gg(1) = xj * fac
1122 c!          gg(2) = yj * fac
1123 c!          gg(3) = zj * fac
1124           gg(1) = fac
1125           gg(2) = fac
1126           gg(3) = fac
1127 c!      write (*,*) "gg(1) = ", gg(1)
1128 c!      write (*,*) "gg(2) = ", gg(2)
1129 c!      write (*,*) "gg(3) = ", gg(3)
1130 c! The angular derivatives of GGB are brought together in sc_grad
1131 c!-------------------------------------------------------------------
1132 c! Fcav
1133 c!
1134 c! Catch gly-gly interactions to skip calculation of something that
1135 c! does not exist
1136
1137       IF (itypi.eq.10.and.itypj.eq.10) THEN
1138        Fcav = 0.0d0
1139        dFdR = 0.0d0
1140        dCAVdOM1  = 0.0d0
1141        dCAVdOM2  = 0.0d0
1142        dCAVdOM12 = 0.0d0
1143       ELSE
1144
1145 c! we are not 2 glycines, so we calculate Fcav (and maybe more)
1146        fac = chis1 * sqom1 + chis2 * sqom2
1147      &     - 2.0d0 * chis12 * om1 * om2 * om12
1148 c! we will use pom later in Gcav, so dont mess with it!
1149        pom = 1.0d0 - chis1 * chis2 * sqom12
1150
1151        Lambf = (1.0d0 - (fac / pom))
1152        Lambf = dsqrt(Lambf)
1153
1154
1155        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
1156 c!       write (*,*) "sparrow = ", sparrow
1157        Chif = Rtail * sparrow
1158        ChiLambf = Chif * Lambf
1159        eagle = dsqrt(ChiLambf)
1160        bat = ChiLambf ** 11.0d0
1161
1162        top = b1 * ( eagle + b2 * ChiLambf - b3 )
1163        bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
1164        botsq = bot * bot
1165
1166 c!      write (*,*) "sig1 = ",sig1
1167 c!      write (*,*) "sig2 = ",sig2
1168 c!      write (*,*) "Rtail = ",Rtail
1169 c!      write (*,*) "sparrow = ",sparrow
1170 c!      write (*,*) "Chis1 = ", chis1
1171 c!      write (*,*) "Chis2 = ", chis2
1172 c!      write (*,*) "Chis12 = ", chis12
1173 c!      write (*,*) "om1 = ", om1
1174 c!      write (*,*) "om2 = ", om2
1175 c!      write (*,*) "om12 = ", om12
1176 c!      write (*,*) "sqom1 = ", sqom1
1177 c!      write (*,*) "sqom2 = ", sqom2
1178 c!      write (*,*) "sqom12 = ", sqom12
1179 c!      write (*,*) "Lambf = ",Lambf
1180 c!      write (*,*) "b1 = ",b1
1181 c!      write (*,*) "b2 = ",b2
1182 c!      write (*,*) "b3 = ",b3
1183 c!      write (*,*) "b4 = ",b4
1184 c!      write (*,*) "top = ",top
1185 c!      write (*,*) "bot = ",bot
1186        Fcav = top / bot
1187 c!       Fcav = 0.0d0
1188 c!      write (*,*) "Fcav = ", Fcav
1189 c!-------------------------------------------------------------------
1190 c! derivative of Fcav is Gcav...
1191 c!---------------------------------------------------
1192
1193        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
1194        dbot = 12.0d0 * b4 * bat * Lambf
1195        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
1196 c!       dFdR = 0.0d0
1197 c!      write (*,*) "dFcav/dR = ", dFdR
1198
1199        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
1200        dbot = 12.0d0 * b4 * bat * Chif
1201        eagle = Lambf * pom
1202        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
1203        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
1204        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)
1205      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)
1206
1207        dFdL = ((dtop * bot - top * dbot) / botsq)
1208 c!       dFdL = 0.0d0
1209        dCAVdOM1  = dFdL * ( dFdOM1 )
1210        dCAVdOM2  = dFdL * ( dFdOM2 )
1211        dCAVdOM12 = dFdL * ( dFdOM12 )
1212 c!      write (*,*) "dFcav/dOM1 = ", dCAVdOM1
1213 c!      write (*,*) "dFcav/dOM2 = ", dCAVdOM2
1214 c!      write (*,*) "dFcav/dOM12 = ", dCAVdOM12
1215 c!      write (*,*) ""
1216 c!-------------------------------------------------------------------
1217 c! Finally, add the distance derivatives of GB and Fcav to gvdwc
1218 c! Pom is used here to project the gradient vector into
1219 c! cartesian coordinates and at the same time contains
1220 c! dXhb/dXsc derivative (for charged amino acids
1221 c! location of hydrophobic centre of interaction is not
1222 c! the same as geometric centre of side chain, this
1223 c! derivative takes that into account)
1224 c! derivatives of omega angles will be added in sc_grad
1225
1226        DO k= 1, 3
1227         ertail(k) = Rtail_distance(k)/Rtail
1228        END DO
1229        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
1230        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
1231        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1232        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1233        DO k = 1, 3
1234 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1235 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1236         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
1237         gvdwx(k,i) = gvdwx(k,i)
1238      &             - (( dFdR + gg(k) ) * pom)
1239 c!     &             - ( dFdR * pom )
1240         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
1241         gvdwx(k,j) = gvdwx(k,j)
1242      &             + (( dFdR + gg(k) ) * pom)
1243 c!     &             + ( dFdR * pom )
1244
1245         gvdwc(k,i) = gvdwc(k,i)
1246      &             - (( dFdR + gg(k) ) * ertail(k))
1247 c!     &             - ( dFdR * ertail(k))
1248
1249         gvdwc(k,j) = gvdwc(k,j)
1250      &             + (( dFdR + gg(k) ) * ertail(k))
1251 c!     &             + ( dFdR * ertail(k))
1252
1253         gg(k) = 0.0d0
1254 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1255 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1256       END DO
1257
1258 c!-------------------------------------------------------------------
1259 c! Compute head-head and head-tail energies for each state
1260
1261           isel = iabs(Qi) + iabs(Qj)
1262           IF (isel.eq.0) THEN
1263 c! No charges - do nothing
1264            eheadtail = 0.0d0
1265
1266           ELSE IF (isel.eq.4) THEN
1267 c! Calculate dipole-dipole interactions
1268            CALL edd(ecl)
1269            eheadtail = ECL
1270
1271           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
1272 c! Charge-nonpolar interactions
1273            CALL eqn(epol)
1274            eheadtail = epol
1275
1276           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
1277 c! Nonpolar-charge interactions
1278            CALL enq(epol)
1279            eheadtail = epol
1280
1281           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
1282 c! Charge-dipole interactions
1283            CALL eqd(ecl, elj, epol)
1284            eheadtail = ECL + elj + epol
1285
1286           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
1287 c! Dipole-charge interactions
1288            CALL edq(ecl, elj, epol)
1289            eheadtail = ECL + elj + epol
1290
1291           ELSE IF ((isel.eq.2.and.
1292      &          iabs(Qi).eq.1).and.
1293      &          nstate(itypi,itypj).eq.1) THEN
1294 c! Same charge-charge interaction ( +/+ or -/- )
1295            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
1296            eheadtail = ECL + Egb + Epol + Fisocav + Elj
1297
1298           ELSE IF ((isel.eq.2.and.
1299      &          iabs(Qi).eq.1).and.
1300      &          nstate(itypi,itypj).ne.1) THEN
1301 c! Different charge-charge interaction ( +/- or -/+ )
1302            CALL energy_quad
1303      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1304           END IF
1305        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
1306 c!      write (*,*) "evdw = ", evdw
1307 c!      write (*,*) "Fcav = ", Fcav
1308 c!      write (*,*) "eheadtail = ", eheadtail
1309        evdw = evdw
1310      &      + Fcav
1311      &      + eheadtail
1312        IF (energy_dec) write (iout,'(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        IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
1317      &  restyp(itype(i)),i,restyp(itype(j)),j,
1318      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1319      &  Equad,evdw
1320 #IFDEF CHECK_MOMO
1321        evdw = 0.0d0
1322        END DO ! troll
1323 #ENDIF
1324
1325 c!-------------------------------------------------------------------
1326 c! As all angular derivatives are done, now we sum them up,
1327 c! then transform and project into cartesian vectors and add to gvdwc
1328 c! We call sc_grad always, with the exception of +/- interaction.
1329 c! This is because energy_quad subroutine needs to handle
1330 c! this job in his own way.
1331 c! This IS probably not very efficient and SHOULD be optimised
1332 c! but it will require major restructurization of emomo
1333 c! so it will be left as it is for now
1334 c!       write (*,*) 'troll1, nstate =', nstate (itypi,itypj)
1335        IF (nstate(itypi,itypj).eq.1) THEN
1336 #ifdef TSCSC
1337         IF (bb(itypi,itypj).gt.0) THEN
1338          CALL sc_grad
1339         ELSE
1340          CALL sc_grad_T
1341         END IF
1342 #else
1343         CALL sc_grad
1344 #endif
1345        END IF
1346 c!-------------------------------------------------------------------
1347 c! NAPISY KONCOWE
1348          END DO   ! j
1349         END DO    ! iint
1350        END DO     ! i
1351 c      write (iout,*) "Number of loop steps in EGB:",ind
1352 c      energy_dec=.false.
1353        RETURN
1354       END SUBROUTINE emomo
1355 c! END OF MOMO
1356
1357
1358 C-----------------------------------------------------------------------------
1359
1360
1361       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
1362        IMPLICIT NONE
1363        INCLUDE 'DIMENSIONS'
1364        INCLUDE 'sizesclu.dat'
1365        INCLUDE 'COMMON.CALC'
1366        INCLUDE 'COMMON.CHAIN'
1367        INCLUDE 'COMMON.CONTROL'
1368        INCLUDE 'COMMON.DERIV'
1369        INCLUDE 'COMMON.EMP'
1370        INCLUDE 'COMMON.GEO'
1371        INCLUDE 'COMMON.INTERACT'
1372        INCLUDE 'COMMON.IOUNITS'
1373        INCLUDE 'COMMON.LOCAL'
1374        INCLUDE 'COMMON.NAMES'
1375        INCLUDE 'COMMON.VAR'
1376        double precision scalar, facd3, facd4, federmaus, adler
1377 c! Epol and Gpol analytical parameters
1378        alphapol1 = alphapol(itypi,itypj)
1379        alphapol2 = alphapol(itypj,itypi)
1380 c! Fisocav and Gisocav analytical parameters
1381        al1  = alphiso(1,itypi,itypj)
1382        al2  = alphiso(2,itypi,itypj)
1383        al3  = alphiso(3,itypi,itypj)
1384        al4  = alphiso(4,itypi,itypj)
1385        csig = (1.0d0
1386      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1387      &      + sigiso2(itypi,itypj)**2.0d0))
1388 c!
1389        pis  = sig0head(itypi,itypj)
1390        eps_head = epshead(itypi,itypj)
1391        Rhead_sq = Rhead * Rhead
1392 c! R1 - distance between head of ith side chain and tail of jth sidechain
1393 c! R2 - distance between head of jth side chain and tail of ith sidechain
1394        R1 = 0.0d0
1395        R2 = 0.0d0
1396        DO k = 1, 3
1397 c! Calculate head-to-tail distances needed by Epol
1398         R1=R1+(ctail(k,2)-chead(k,1))**2
1399         R2=R2+(chead(k,2)-ctail(k,1))**2
1400        END DO
1401 c! Pitagoras
1402        R1 = dsqrt(R1)
1403        R2 = dsqrt(R2)
1404
1405 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1406 c!     &        +dhead(1,1,itypi,itypj))**2))
1407 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1408 c!     &        +dhead(2,1,itypi,itypj))**2))
1409
1410 c!-------------------------------------------------------------------
1411 c! Coulomb electrostatic interaction
1412        Ecl = (332.0d0 * Qij) / Rhead
1413 c! derivative of Ecl is Gcl...
1414        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
1415        dGCLdOM1 = 0.0d0
1416        dGCLdOM2 = 0.0d0
1417        dGCLdOM12 = 0.0d0
1418 c!-------------------------------------------------------------------
1419 c! Generalised Born Solvent Polarization
1420 c! Charged head polarizes the solvent
1421        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1422        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1423        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1424 c! Derivative of Egb is Ggb...
1425        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1426        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1427      &        / ( 2.0d0 * Fgb )
1428        dGGBdR = dGGBdFGB * dFGBdR
1429 c!-------------------------------------------------------------------
1430 c! Fisocav - isotropic cavity creation term
1431 c! or "how much energy it costs to put charged head in water"
1432        pom = Rhead * csig
1433        top = al1 * (dsqrt(pom) + al2 * pom - al3)
1434        bot = (1.0d0 + al4 * pom**12.0d0)
1435        botsq = bot * bot
1436        FisoCav = top / bot
1437 c!      write (*,*) "Rhead = ",Rhead
1438 c!      write (*,*) "csig = ",csig
1439 c!      write (*,*) "pom = ",pom
1440 c!      write (*,*) "al1 = ",al1
1441 c!      write (*,*) "al2 = ",al2
1442 c!      write (*,*) "al3 = ",al3
1443 c!      write (*,*) "al4 = ",al4
1444 c!      write (*,*) "top = ",top
1445 c!      write (*,*) "bot = ",bot
1446 c! Derivative of Fisocav is GCV...
1447        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1448        dbot = 12.0d0 * al4 * pom ** 11.0d0
1449        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1450 c!-------------------------------------------------------------------
1451 c! Epol
1452 c! Polarization energy - charged heads polarize hydrophobic "neck"
1453        MomoFac1 = (1.0d0 - chi1 * sqom2)
1454        MomoFac2 = (1.0d0 - chi2 * sqom1)
1455        RR1  = ( R1 * R1 ) / MomoFac1
1456        RR2  = ( R2 * R2 ) / MomoFac2
1457        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1458        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1459        fgb1 = sqrt( RR1 + a12sq * ee1 )
1460        fgb2 = sqrt( RR2 + a12sq * ee2 )
1461        epol = 332.0d0 * eps_inout_fac * (
1462      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1463 c!       epol = 0.0d0
1464 c       write (*,*) "eps_inout_fac = ",eps_inout_fac
1465 c       write (*,*) "alphapol1 = ", alphapol1
1466 c       write (*,*) "alphapol2 = ", alphapol2
1467 c       write (*,*) "fgb1 = ", fgb1
1468 c       write (*,*) "fgb2 = ", fgb2
1469 c       write (*,*) "epol = ", epol
1470 c! derivative of Epol is Gpol...
1471        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1472      &          / (fgb1 ** 5.0d0)
1473        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1474      &          / (fgb2 ** 5.0d0)
1475        dFGBdR1 = ( (R1 / MomoFac1)
1476      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
1477      &        / ( 2.0d0 * fgb1 )
1478        dFGBdR2 = ( (R2 / MomoFac2)
1479      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
1480      &        / ( 2.0d0 * fgb2 )
1481        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1482      &          * ( 2.0d0 - 0.5d0 * ee1) )
1483      &          / ( 2.0d0 * fgb1 )
1484        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1485      &          * ( 2.0d0 - 0.5d0 * ee2) )
1486      &          / ( 2.0d0 * fgb2 )
1487        dPOLdR1 = dPOLdFGB1 * dFGBdR1
1488 c!       dPOLdR1 = 0.0d0
1489        dPOLdR2 = dPOLdFGB2 * dFGBdR2
1490 c!       dPOLdR2 = 0.0d0
1491        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1492 c!       dPOLdOM1 = 0.0d0
1493        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1494 c!       dPOLdOM2 = 0.0d0
1495 c!-------------------------------------------------------------------
1496 c! Elj
1497 c! Lennard-Jones 6-12 interaction between heads
1498        pom = (pis / Rhead)**6.0d0
1499        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1500 c! derivative of Elj is Glj
1501        dGLJdR = 4.0d0 * eps_head
1502      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1503      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1504 c!-------------------------------------------------------------------
1505 c! Return the results
1506 c! These things do the dRdX derivatives, that is
1507 c! allow us to change what we see from function that changes with
1508 c! distance to function that changes with LOCATION (of the interaction
1509 c! site)
1510        DO k = 1, 3
1511         erhead(k) = Rhead_distance(k)/Rhead
1512         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1513         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1514        END DO
1515
1516        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1517        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1518        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1519        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1520        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1521        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1522        facd1 = d1 * vbld_inv(i+nres)
1523        facd2 = d2 * vbld_inv(j+nres)
1524        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1525        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1526
1527 c! Now we add appropriate partial derivatives (one in each dimension)
1528        DO k = 1, 3
1529         hawk   = (erhead_tail(k,1) +
1530      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
1531         condor = (erhead_tail(k,2) +
1532      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
1533
1534         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1535         gvdwx(k,i) = gvdwx(k,i)
1536      &             - dGCLdR * pom
1537      &             - dGGBdR * pom
1538      &             - dGCVdR * pom
1539      &             - dPOLdR1 * hawk
1540      &             - dPOLdR2 * (erhead_tail(k,2)
1541      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1542      &             - dGLJdR * pom
1543
1544         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1545         gvdwx(k,j) = gvdwx(k,j)
1546      &             + dGCLdR * pom
1547      &             + dGGBdR * pom
1548      &             + dGCVdR * pom
1549      &             + dPOLdR1 * (erhead_tail(k,1)
1550      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1551      &             + dPOLdR2 * condor
1552      &             + dGLJdR * pom
1553
1554         gvdwc(k,i) = gvdwc(k,i)
1555      &             - dGCLdR * erhead(k)
1556      &             - dGGBdR * erhead(k)
1557      &             - dGCVdR * erhead(k)
1558      &             - dPOLdR1 * erhead_tail(k,1)
1559      &             - dPOLdR2 * erhead_tail(k,2)
1560      &             - dGLJdR * erhead(k)
1561
1562         gvdwc(k,j) = gvdwc(k,j)
1563      &             + dGCLdR * erhead(k)
1564      &             + dGGBdR * erhead(k)
1565      &             + dGCVdR * erhead(k)
1566      &             + dPOLdR1 * erhead_tail(k,1)
1567      &             + dPOLdR2 * erhead_tail(k,2)
1568      &             + dGLJdR * erhead(k)
1569
1570        END DO
1571        RETURN
1572       END SUBROUTINE eqq
1573 c!-------------------------------------------------------------------
1574       SUBROUTINE energy_quad
1575      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1576        IMPLICIT NONE
1577        INCLUDE 'DIMENSIONS'
1578        INCLUDE 'sizesclu.dat'
1579        INCLUDE 'COMMON.CALC'
1580        INCLUDE 'COMMON.CHAIN'
1581        INCLUDE 'COMMON.CONTROL'
1582        INCLUDE 'COMMON.DERIV'
1583        INCLUDE 'COMMON.EMP'
1584        INCLUDE 'COMMON.GEO'
1585        INCLUDE 'COMMON.INTERACT'
1586        INCLUDE 'COMMON.IOUNITS'
1587        INCLUDE 'COMMON.LOCAL'
1588        INCLUDE 'COMMON.NAMES'
1589        INCLUDE 'COMMON.VAR'
1590        double precision scalar
1591        double precision ener(4)
1592        double precision dcosom1(3),dcosom2(3)
1593 c! used in Epol derivatives
1594        double precision facd3, facd4
1595        double precision federmaus, adler
1596 c! Epol and Gpol analytical parameters
1597        alphapol1 = alphapol(itypi,itypj)
1598        alphapol2 = alphapol(itypj,itypi)
1599 c! Fisocav and Gisocav analytical parameters
1600        al1  = alphiso(1,itypi,itypj)
1601        al2  = alphiso(2,itypi,itypj)
1602        al3  = alphiso(3,itypi,itypj)
1603        al4  = alphiso(4,itypi,itypj)
1604        csig = (1.0d0
1605      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1606      &      + sigiso2(itypi,itypj)**2.0d0))
1607 c!
1608        w1   = wqdip(1,itypi,itypj)
1609        w2   = wqdip(2,itypi,itypj)
1610        pis  = sig0head(itypi,itypj)
1611        eps_head = epshead(itypi,itypj)
1612 c! First things first:
1613 c! We need to do sc_grad's job with GB and Fcav
1614        eom1  =
1615      &         eps2der * eps2rt_om1
1616      &       - 2.0D0 * alf1 * eps3der
1617      &       + sigder * sigsq_om1
1618      &       + dCAVdOM1
1619        eom2  =
1620      &         eps2der * eps2rt_om2
1621      &       + 2.0D0 * alf2 * eps3der
1622      &       + sigder * sigsq_om2
1623      &       + dCAVdOM2
1624        eom12 =
1625      &         evdwij  * eps1_om12
1626      &       + eps2der * eps2rt_om12
1627      &       - 2.0D0 * alf12 * eps3der
1628      &       + sigder *sigsq_om12
1629      &       + dCAVdOM12
1630 c! now some magical transformations to project gradient into
1631 c! three cartesian vectors
1632        DO k = 1, 3
1633         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1634         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1635         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
1636 c! this acts on hydrophobic center of interaction
1637         gvdwx(k,i)= gvdwx(k,i) - gg(k)
1638      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1639      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1640         gvdwx(k,j)= gvdwx(k,j) + gg(k)
1641      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1642      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1643 c! this acts on Calpha
1644         gvdwc(k,i)=gvdwc(k,i)-gg(k)
1645         gvdwc(k,j)=gvdwc(k,j)+gg(k)
1646        END DO
1647 c! sc_grad is done, now we will compute
1648        eheadtail = 0.0d0
1649        eom1 = 0.0d0
1650        eom2 = 0.0d0
1651        eom12 = 0.0d0
1652
1653 c! ENERGY DEBUG
1654 c!       ii = 1
1655 c!       jj = 1
1656 c!       d1 = dhead(1, 1, itypi, itypj)
1657 c!       d2 = dhead(2, 1, itypi, itypj)
1658 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1659 c!     &        +dhead(1,ii,itypi,itypj))**2))
1660 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1661 c!     &        +dhead(2,jj,itypi,itypj))**2))
1662 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1663 c! END OF ENERGY DEBUG
1664 c*************************************************************
1665        DO istate = 1, nstate(itypi,itypj)
1666 c*************************************************************
1667         IF (istate.ne.1) THEN
1668          IF (istate.lt.3) THEN
1669           ii = 1
1670          ELSE
1671           ii = 2
1672          END IF
1673         jj = istate/ii
1674         d1 = dhead(1,ii,itypi,itypj)
1675         d2 = dhead(2,jj,itypi,itypj)
1676         DO k = 1,3
1677          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
1678          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
1679          Rhead_distance(k) = chead(k,2) - chead(k,1)
1680         END DO
1681 c! pitagoras (root of sum of squares)
1682         Rhead = dsqrt(
1683      &          (Rhead_distance(1)*Rhead_distance(1))
1684      &        + (Rhead_distance(2)*Rhead_distance(2))
1685      &        + (Rhead_distance(3)*Rhead_distance(3)))
1686         END IF
1687         Rhead_sq = Rhead * Rhead
1688
1689 c! R1 - distance between head of ith side chain and tail of jth sidechain
1690 c! R2 - distance between head of jth side chain and tail of ith sidechain
1691         R1 = 0.0d0
1692         R2 = 0.0d0
1693         DO k = 1, 3
1694 c! Calculate head-to-tail distances
1695          R1=R1+(ctail(k,2)-chead(k,1))**2
1696          R2=R2+(chead(k,2)-ctail(k,1))**2
1697         END DO
1698 c! Pitagoras
1699         R1 = dsqrt(R1)
1700         R2 = dsqrt(R2)
1701
1702 c! ENERGY DEBUG
1703 c!      write (*,*) "istate = ", istate
1704 c!      write (*,*) "ii = ", ii
1705 c!      write (*,*) "jj = ", jj
1706 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1707 c!     &        +dhead(1,ii,itypi,itypj))**2))
1708 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1709 c!     &        +dhead(2,jj,itypi,itypj))**2))
1710 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1711 c!      Rhead_sq = Rhead * Rhead
1712 c!      write (*,*) "d1 = ",d1
1713 c!      write (*,*) "d2 = ",d2
1714 c!      write (*,*) "R1 = ",R1
1715 c!      write (*,*) "R2 = ",R2
1716 c!      write (*,*) "Rhead = ",Rhead
1717 c! END OF ENERGY DEBUG
1718
1719 c!-------------------------------------------------------------------
1720 c! Coulomb electrostatic interaction
1721         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
1722 c!        Ecl = 0.0d0
1723 c!        write (*,*) "Ecl = ", Ecl
1724 c! derivative of Ecl is Gcl...
1725         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
1726 c!        dGCLdR = 0.0d0
1727         dGCLdOM1 = 0.0d0
1728         dGCLdOM2 = 0.0d0
1729         dGCLdOM12 = 0.0d0
1730 c!-------------------------------------------------------------------
1731 c! Generalised Born Solvent Polarization
1732         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1733         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1734         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1735 c!        Egb = 0.0d0
1736 c!      write (*,*) "a1*a2 = ", a12sq
1737 c!      write (*,*) "Rhead = ", Rhead
1738 c!      write (*,*) "Rhead_sq = ", Rhead_sq
1739 c!      write (*,*) "ee = ", ee
1740 c!      write (*,*) "Fgb = ", Fgb
1741 c!      write (*,*) "fac = ", eps_inout_fac
1742 c!      write (*,*) "Qij = ", Qij
1743 c!      write (*,*) "Egb = ", Egb
1744 c! Derivative of Egb is Ggb...
1745 c! dFGBdR is used by Quad's later...
1746         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1747         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1748      &         / ( 2.0d0 * Fgb )
1749         dGGBdR = dGGBdFGB * dFGBdR
1750 c!        dGGBdR = 0.0d0
1751 c!-------------------------------------------------------------------
1752 c! Fisocav - isotropic cavity creation term
1753         pom = Rhead * csig
1754         top = al1 * (dsqrt(pom) + al2 * pom - al3)
1755         bot = (1.0d0 + al4 * pom**12.0d0)
1756         botsq = bot * bot
1757         FisoCav = top / bot
1758 c!        FisoCav = 0.0d0
1759 c!      write (*,*) "pom = ",pom
1760 c!      write (*,*) "al1 = ",al1
1761 c!      write (*,*) "al2 = ",al2
1762 c!      write (*,*) "al3 = ",al3
1763 c!      write (*,*) "al4 = ",al4
1764 c!      write (*,*) "top = ",top
1765 c!      write (*,*) "bot = ",bot
1766 c!      write (*,*) "Fisocav = ", Fisocav
1767
1768 c! Derivative of Fisocav is GCV...
1769         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1770         dbot = 12.0d0 * al4 * pom ** 11.0d0
1771         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1772 c!        dGCVdR = 0.0d0
1773 c!-------------------------------------------------------------------
1774 c! Polarization energy
1775 c! Epol
1776         MomoFac1 = (1.0d0 - chi1 * sqom2)
1777         MomoFac2 = (1.0d0 - chi2 * sqom1)
1778         RR1  = ( R1 * R1 ) / MomoFac1
1779         RR2  = ( R2 * R2 ) / MomoFac2
1780         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1781         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1782         fgb1 = sqrt( RR1 + a12sq * ee1 )
1783         fgb2 = sqrt( RR2 + a12sq * ee2 )
1784         epol = 332.0d0 * eps_inout_fac * (
1785      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1786 c!        epol = 0.0d0
1787 c! derivative of Epol is Gpol...
1788         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1789      &            / (fgb1 ** 5.0d0)
1790         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1791      &            / (fgb2 ** 5.0d0)
1792         dFGBdR1 = ( (R1 / MomoFac1)
1793      &          * ( 2.0d0 - (0.5d0 * ee1) ) )
1794      &          / ( 2.0d0 * fgb1 )
1795         dFGBdR2 = ( (R2 / MomoFac2)
1796      &          * ( 2.0d0 - (0.5d0 * ee2) ) )
1797      &          / ( 2.0d0 * fgb2 )
1798         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1799      &           * ( 2.0d0 - 0.5d0 * ee1) )
1800      &           / ( 2.0d0 * fgb1 )
1801         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1802      &           * ( 2.0d0 - 0.5d0 * ee2) )
1803      &           / ( 2.0d0 * fgb2 )
1804         dPOLdR1 = dPOLdFGB1 * dFGBdR1
1805 c!        dPOLdR1 = 0.0d0
1806         dPOLdR2 = dPOLdFGB2 * dFGBdR2
1807 c!        dPOLdR2 = 0.0d0
1808         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1809 c!        dPOLdOM1 = 0.0d0
1810         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1811 c!        dPOLdOM2 = 0.0d0
1812 c!-------------------------------------------------------------------
1813 c! Elj
1814         pom = (pis / Rhead)**6.0d0
1815         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1816 c!        Elj = 0.0d0
1817 c! derivative of Elj is Glj
1818         dGLJdR = 4.0d0 * eps_head
1819      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1820      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1821 c!        dGLJdR = 0.0d0
1822 c!-------------------------------------------------------------------
1823 c! Equad
1824        IF (Wqd.ne.0.0d0) THEN
1825         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)
1826      &        - 37.5d0  * ( sqom1 + sqom2 )
1827      &        + 157.5d0 * ( sqom1 * sqom2 )
1828      &        - 45.0d0  * om1*om2*om12
1829         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
1830         Equad = fac * Beta1
1831 c!        Equad = 0.0d0
1832 c! derivative of Equad...
1833         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
1834 c!        dQUADdR = 0.0d0
1835         dQUADdOM1 = fac
1836      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
1837 c!        dQUADdOM1 = 0.0d0
1838         dQUADdOM2 = fac
1839      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
1840 c!        dQUADdOM2 = 0.0d0
1841         dQUADdOM12 = fac
1842      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )
1843 c!        dQUADdOM12 = 0.0d0
1844         ELSE
1845          Beta1 = 0.0d0
1846          Equad = 0.0d0
1847         END IF
1848 c!-------------------------------------------------------------------
1849 c! Return the results
1850 c! Angular stuff
1851         eom1 = dPOLdOM1 + dQUADdOM1
1852         eom2 = dPOLdOM2 + dQUADdOM2
1853         eom12 = dQUADdOM12
1854 c! now some magical transformations to project gradient into
1855 c! three cartesian vectors
1856         DO k = 1, 3
1857          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1858          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1859          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
1860         END DO
1861 c! Radial stuff
1862         DO k = 1, 3
1863          erhead(k) = Rhead_distance(k)/Rhead
1864          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1865          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1866         END DO
1867         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1868         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1869         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1870         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1871         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1872         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1873         facd1 = d1 * vbld_inv(i+nres)
1874         facd2 = d2 * vbld_inv(j+nres)
1875         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1876         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1877 c! Throw the results into gheadtail which holds gradients
1878 c! for each micro-state
1879         DO k = 1, 3
1880          hawk   = erhead_tail(k,1) +
1881      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
1882          condor = erhead_tail(k,2) +
1883      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
1884
1885          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1886 c! this acts on hydrophobic center of interaction
1887          gheadtail(k,1,1) = gheadtail(k,1,1)
1888      &                    - dGCLdR * pom
1889      &                    - dGGBdR * pom
1890      &                    - dGCVdR * pom
1891      &                    - dPOLdR1 * hawk
1892      &                    - dPOLdR2 * (erhead_tail(k,2)
1893      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1894      &                    - dGLJdR * pom
1895      &                    - dQUADdR * pom
1896      &                    - tuna(k)
1897      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1898      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1899
1900          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1901 c! this acts on hydrophobic center of interaction
1902          gheadtail(k,2,1) = gheadtail(k,2,1)
1903      &                    + dGCLdR * pom
1904      &                    + dGGBdR * pom
1905      &                    + dGCVdR * pom
1906      &                    + dPOLdR1 * (erhead_tail(k,1)
1907      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1908      &                    + dPOLdR2 * condor
1909      &                    + dGLJdR * pom
1910      &                    + dQUADdR * pom
1911      &                    + tuna(k)
1912      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1913      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1914
1915 c! this acts on Calpha
1916          gheadtail(k,3,1) = gheadtail(k,3,1)
1917      &                    - dGCLdR * erhead(k)
1918      &                    - dGGBdR * erhead(k)
1919      &                    - dGCVdR * erhead(k)
1920      &                    - dPOLdR1 * erhead_tail(k,1)
1921      &                    - dPOLdR2 * erhead_tail(k,2)
1922      &                    - dGLJdR * erhead(k)
1923      &                    - dQUADdR * erhead(k)
1924      &                    - tuna(k)
1925
1926 c! this acts on Calpha
1927          gheadtail(k,4,1) = gheadtail(k,4,1)
1928      &                    + dGCLdR * erhead(k)
1929      &                    + dGGBdR * erhead(k)
1930      &                    + dGCVdR * erhead(k)
1931      &                    + dPOLdR1 * erhead_tail(k,1)
1932      &                    + dPOLdR2 * erhead_tail(k,2)
1933      &                    + dGLJdR * erhead(k)
1934      &                    + dQUADdR * erhead(k)
1935      &                    + tuna(k)
1936         END DO
1937 c!      write(*,*) "ECL = ", Ecl
1938 c!      write(*,*) "Egb = ", Egb
1939 c!      write(*,*) "Epol = ", Epol
1940 c!      write(*,*) "Fisocav = ", Fisocav
1941 c!      write(*,*) "Elj = ", Elj
1942 c!      write(*,*) "Equad = ", Equad
1943 c!      write(*,*) "wstate = ", wstate(istate,itypi,itypj)
1944 c!      write(*,*) "eheadtail = ", eheadtail
1945 c!      write(*,*) "TROLL = ", dexp(-betaTT * ener(istate))
1946 c!      write(*,*) "dGCLdR = ", dGCLdR
1947 c!      write(*,*) "dGGBdR = ", dGGBdR
1948 c!      write(*,*) "dGCVdR = ", dGCVdR
1949 c!      write(*,*) "dPOLdR1 = ", dPOLdR1
1950 c!      write(*,*) "dPOLdR2 = ", dPOLdR2
1951 c!      write(*,*) "dGLJdR = ", dGLJdR
1952 c!      write(*,*) "dQUADdR = ", dQUADdR
1953 c!      write(*,*) "tuna(",k,") = ", tuna(k)
1954         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
1955         eheadtail = eheadtail
1956      &            + wstate(istate, itypi, itypj)
1957      &            * dexp(-betaTT * ener(istate))
1958 c! foreach cartesian dimension
1959         DO k = 1, 3
1960 c! foreach of two gvdwx and gvdwc
1961          DO l = 1, 4
1962           gheadtail(k,l,2) = gheadtail(k,l,2)
1963      &                     + wstate( istate, itypi, itypj )
1964      &                     * dexp(-betaTT * ener(istate))
1965      &                     * gheadtail(k,l,1)
1966           gheadtail(k,l,1) = 0.0d0
1967          END DO
1968         END DO
1969        END DO
1970 c! Here ended the gigantic DO istate = 1, 4, which starts
1971 c! at the beggining of the subroutine
1972
1973        DO k = 1, 3
1974         DO l = 1, 4
1975          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
1976         END DO
1977         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
1978         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
1979         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
1980         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
1981         DO l = 1, 4
1982          gheadtail(k,l,1) = 0.0d0
1983          gheadtail(k,l,2) = 0.0d0
1984         END DO
1985        END DO
1986        eheadtail = (-dlog(eheadtail)) / betaTT
1987        dPOLdOM1 = 0.0d0
1988        dPOLdOM2 = 0.0d0
1989        dQUADdOM1 = 0.0d0
1990        dQUADdOM2 = 0.0d0
1991        dQUADdOM12 = 0.0d0
1992        RETURN
1993       END SUBROUTINE energy_quad
1994
1995
1996 c!-------------------------------------------------------------------
1997
1998
1999       SUBROUTINE eqn(Epol)
2000       IMPLICIT NONE
2001       INCLUDE 'DIMENSIONS'
2002       INCLUDE 'sizesclu.dat'
2003       INCLUDE 'COMMON.CALC'
2004       INCLUDE 'COMMON.CHAIN'
2005       INCLUDE 'COMMON.CONTROL'
2006       INCLUDE 'COMMON.DERIV'
2007       INCLUDE 'COMMON.EMP'
2008       INCLUDE 'COMMON.GEO'
2009       INCLUDE 'COMMON.INTERACT'
2010       INCLUDE 'COMMON.IOUNITS'
2011       INCLUDE 'COMMON.LOCAL'
2012       INCLUDE 'COMMON.NAMES'
2013       INCLUDE 'COMMON.VAR'
2014       double precision scalar, facd4, federmaus
2015       alphapol1 = alphapol(itypi,itypj)
2016 c! R1 - distance between head of ith side chain and tail of jth sidechain
2017        R1 = 0.0d0
2018        DO k = 1, 3
2019 c! Calculate head-to-tail distances
2020         R1=R1+(ctail(k,2)-chead(k,1))**2
2021        END DO
2022 c! Pitagoras
2023        R1 = dsqrt(R1)
2024
2025 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2026 c!     &        +dhead(1,1,itypi,itypj))**2))
2027 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2028 c!     &        +dhead(2,1,itypi,itypj))**2))
2029 c--------------------------------------------------------------------
2030 c Polarization energy
2031 c Epol
2032        MomoFac1 = (1.0d0 - chi1 * sqom2)
2033        RR1  = R1 * R1 / MomoFac1
2034        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2035        fgb1 = sqrt( RR1 + a12sq * ee1)
2036        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2037 c!       epol = 0.0d0
2038 c!------------------------------------------------------------------
2039 c! derivative of Epol is Gpol...
2040        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2041      &          / (fgb1 ** 5.0d0)
2042        dFGBdR1 = ( (R1 / MomoFac1)
2043      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2044      &        / ( 2.0d0 * fgb1 )
2045        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2046      &          * (2.0d0 - 0.5d0 * ee1) )
2047      &          / (2.0d0 * fgb1)
2048        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2049 c!       dPOLdR1 = 0.0d0
2050        dPOLdOM1 = 0.0d0
2051        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2052 c!       dPOLdOM2 = 0.0d0
2053 c!-------------------------------------------------------------------
2054 c! Return the results
2055 c! (see comments in Eqq)
2056        DO k = 1, 3
2057         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2058        END DO
2059        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2060        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2061        facd1 = d1 * vbld_inv(i+nres)
2062        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2063
2064        DO k = 1, 3
2065         hawk = (erhead_tail(k,1) +
2066      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2067
2068         gvdwx(k,i) = gvdwx(k,i)
2069      &             - dPOLdR1 * hawk
2070         gvdwx(k,j) = gvdwx(k,j)
2071      &             + dPOLdR1 * (erhead_tail(k,1)
2072      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2073
2074         gvdwc(k,i) = gvdwc(k,i)
2075      &             - dPOLdR1 * erhead_tail(k,1)
2076         gvdwc(k,j) = gvdwc(k,j)
2077      &             + dPOLdR1 * erhead_tail(k,1)
2078
2079        END DO
2080        RETURN
2081       END SUBROUTINE eqn
2082
2083
2084 c!-------------------------------------------------------------------
2085
2086
2087
2088       SUBROUTINE enq(Epol)
2089        IMPLICIT NONE
2090        INCLUDE 'DIMENSIONS'
2091        INCLUDE 'sizesclu.dat'
2092        INCLUDE 'COMMON.CALC'
2093        INCLUDE 'COMMON.CHAIN'
2094        INCLUDE 'COMMON.CONTROL'
2095        INCLUDE 'COMMON.DERIV'
2096        INCLUDE 'COMMON.EMP'
2097        INCLUDE 'COMMON.GEO'
2098        INCLUDE 'COMMON.INTERACT'
2099        INCLUDE 'COMMON.IOUNITS'
2100        INCLUDE 'COMMON.LOCAL'
2101        INCLUDE 'COMMON.NAMES'
2102        INCLUDE 'COMMON.VAR'
2103        double precision scalar, facd3, adler
2104        alphapol2 = alphapol(itypj,itypi)
2105 c! R2 - distance between head of jth side chain and tail of ith sidechain
2106        R2 = 0.0d0
2107        DO k = 1, 3
2108 c! Calculate head-to-tail distances
2109         R2=R2+(chead(k,2)-ctail(k,1))**2
2110        END DO
2111 c! Pitagoras
2112        R2 = dsqrt(R2)
2113
2114 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2115 c!     &        +dhead(1,1,itypi,itypj))**2))
2116 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2117 c!     &        +dhead(2,1,itypi,itypj))**2))
2118 c------------------------------------------------------------------------
2119 c Polarization energy
2120        MomoFac2 = (1.0d0 - chi2 * sqom1)
2121        RR2  = R2 * R2 / MomoFac2
2122        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2123        fgb2 = sqrt(RR2  + a12sq * ee2)
2124        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2125 c!       epol = 0.0d0
2126 c!-------------------------------------------------------------------
2127 c! derivative of Epol is Gpol...
2128        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2129      &          / (fgb2 ** 5.0d0)
2130        dFGBdR2 = ( (R2 / MomoFac2)
2131      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2132      &        / (2.0d0 * fgb2)
2133        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2134      &          * (2.0d0 - 0.5d0 * ee2) )
2135      &          / (2.0d0 * fgb2)
2136        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2137 c!       dPOLdR2 = 0.0d0
2138        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2139 c!       dPOLdOM1 = 0.0d0
2140        dPOLdOM2 = 0.0d0
2141 c!-------------------------------------------------------------------
2142 c! Return the results
2143 c! (See comments in Eqq)
2144        DO k = 1, 3
2145         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2146        END DO
2147        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2148        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2149        facd2 = d2 * vbld_inv(j+nres)
2150        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2151        DO k = 1, 3
2152         condor = (erhead_tail(k,2)
2153      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2154
2155         gvdwx(k,i) = gvdwx(k,i)
2156      &             - dPOLdR2 * (erhead_tail(k,2)
2157      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2158         gvdwx(k,j) = gvdwx(k,j)
2159      &             + dPOLdR2 * condor
2160
2161         gvdwc(k,i) = gvdwc(k,i)
2162      &             - dPOLdR2 * erhead_tail(k,2)
2163         gvdwc(k,j) = gvdwc(k,j)
2164      &             + dPOLdR2 * erhead_tail(k,2)
2165
2166        END DO
2167       RETURN
2168       END SUBROUTINE enq
2169
2170
2171 c!-------------------------------------------------------------------
2172
2173
2174       SUBROUTINE eqd(Ecl,Elj,Epol)
2175        IMPLICIT NONE
2176        INCLUDE 'DIMENSIONS'
2177        INCLUDE 'sizesclu.dat'
2178        INCLUDE 'COMMON.CALC'
2179        INCLUDE 'COMMON.CHAIN'
2180        INCLUDE 'COMMON.CONTROL'
2181        INCLUDE 'COMMON.DERIV'
2182        INCLUDE 'COMMON.EMP'
2183        INCLUDE 'COMMON.GEO'
2184        INCLUDE 'COMMON.INTERACT'
2185        INCLUDE 'COMMON.IOUNITS'
2186        INCLUDE 'COMMON.LOCAL'
2187        INCLUDE 'COMMON.NAMES'
2188        INCLUDE 'COMMON.VAR'
2189        double precision scalar, facd4, federmaus
2190        alphapol1 = alphapol(itypi,itypj)
2191        w1        = wqdip(1,itypi,itypj)
2192        w2        = wqdip(2,itypi,itypj)
2193        pis       = sig0head(itypi,itypj)
2194        eps_head   = epshead(itypi,itypj)
2195 c!-------------------------------------------------------------------
2196 c! R1 - distance between head of ith side chain and tail of jth sidechain
2197        R1 = 0.0d0
2198        DO k = 1, 3
2199 c! Calculate head-to-tail distances
2200         R1=R1+(ctail(k,2)-chead(k,1))**2
2201        END DO
2202 c! Pitagoras
2203        R1 = dsqrt(R1)
2204
2205 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2206 c!     &        +dhead(1,1,itypi,itypj))**2))
2207 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2208 c!     &        +dhead(2,1,itypi,itypj))**2))
2209
2210 c!-------------------------------------------------------------------
2211 c! ecl
2212        sparrow  = w1 * Qi * om1
2213        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2214        Ecl = sparrow / Rhead**2.0d0
2215      &     - hawk    / Rhead**4.0d0
2216 c!-------------------------------------------------------------------
2217 c! derivative of ecl is Gcl
2218 c! dF/dr part
2219        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2220      &           + 4.0d0 * hawk    / Rhead**5.0d0
2221 c! dF/dom1
2222        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2223 c! dF/dom2
2224        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2225 c--------------------------------------------------------------------
2226 c Polarization energy
2227 c Epol
2228        MomoFac1 = (1.0d0 - chi1 * sqom2)
2229        RR1  = R1 * R1 / MomoFac1
2230        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2231        fgb1 = sqrt( RR1 + a12sq * ee1)
2232        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2233 c!       epol = 0.0d0
2234 c!------------------------------------------------------------------
2235 c! derivative of Epol is Gpol...
2236        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2237      &          / (fgb1 ** 5.0d0)
2238        dFGBdR1 = ( (R1 / MomoFac1)
2239      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2240      &        / ( 2.0d0 * fgb1 )
2241        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2242      &          * (2.0d0 - 0.5d0 * ee1) )
2243      &          / (2.0d0 * fgb1)
2244        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2245 c!       dPOLdR1 = 0.0d0
2246        dPOLdOM1 = 0.0d0
2247        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2248 c!       dPOLdOM2 = 0.0d0
2249 c!-------------------------------------------------------------------
2250 c! Elj
2251        pom = (pis / Rhead)**6.0d0
2252        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2253 c! derivative of Elj is Glj
2254        dGLJdR = 4.0d0 * eps_head
2255      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2256      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2257 c!-------------------------------------------------------------------
2258 c! Return the results
2259        DO k = 1, 3
2260         erhead(k) = Rhead_distance(k)/Rhead
2261         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2262        END DO
2263
2264        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2265        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2266        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2267        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2268        facd1 = d1 * vbld_inv(i+nres)
2269        facd2 = d2 * vbld_inv(j+nres)
2270        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2271
2272        DO k = 1, 3
2273         hawk = (erhead_tail(k,1) +
2274      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2275
2276         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2277         gvdwx(k,i) = gvdwx(k,i)
2278      &             - dGCLdR * pom
2279      &             - dPOLdR1 * hawk
2280      &             - dGLJdR * pom
2281
2282         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2283         gvdwx(k,j) = gvdwx(k,j)
2284      &             + dGCLdR * pom
2285      &             + dPOLdR1 * (erhead_tail(k,1)
2286      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2287      &             + dGLJdR * pom
2288
2289
2290         gvdwc(k,i) = gvdwc(k,i)
2291      &             - dGCLdR * erhead(k)
2292      &             - dPOLdR1 * erhead_tail(k,1)
2293      &             - dGLJdR * erhead(k)
2294
2295         gvdwc(k,j) = gvdwc(k,j)
2296      &             + dGCLdR * erhead(k)
2297      &             + dPOLdR1 * erhead_tail(k,1)
2298      &             + dGLJdR * erhead(k)
2299
2300        END DO
2301        RETURN
2302       END SUBROUTINE eqd
2303
2304
2305 c!-------------------------------------------------------------------
2306
2307
2308       SUBROUTINE edq(Ecl,Elj,Epol)
2309        IMPLICIT NONE
2310        INCLUDE 'DIMENSIONS'
2311        INCLUDE 'sizesclu.dat'
2312        INCLUDE 'COMMON.CALC'
2313        INCLUDE 'COMMON.CHAIN'
2314        INCLUDE 'COMMON.CONTROL'
2315        INCLUDE 'COMMON.DERIV'
2316        INCLUDE 'COMMON.EMP'
2317        INCLUDE 'COMMON.GEO'
2318        INCLUDE 'COMMON.INTERACT'
2319        INCLUDE 'COMMON.IOUNITS'
2320        INCLUDE 'COMMON.LOCAL'
2321        INCLUDE 'COMMON.NAMES'
2322        INCLUDE 'COMMON.VAR'
2323        double precision scalar, facd3, adler
2324        alphapol2 = alphapol(itypj,itypi)
2325        w1        = wqdip(1,itypi,itypj)
2326        w2        = wqdip(2,itypi,itypj)
2327        pis       = sig0head(itypi,itypj)
2328        eps_head  = epshead(itypi,itypj)
2329 c!-------------------------------------------------------------------
2330 c! R2 - distance between head of jth side chain and tail of ith sidechain
2331        R2 = 0.0d0
2332        DO k = 1, 3
2333 c! Calculate head-to-tail distances
2334         R2=R2+(chead(k,2)-ctail(k,1))**2
2335        END DO
2336 c! Pitagoras
2337        R2 = dsqrt(R2)
2338
2339 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2340 c!     &        +dhead(1,1,itypi,itypj))**2))
2341 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2342 c!     &        +dhead(2,1,itypi,itypj))**2))
2343
2344
2345 c!-------------------------------------------------------------------
2346 c! ecl
2347        sparrow  = w1 * Qi * om1
2348        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2349        ECL = sparrow / Rhead**2.0d0
2350      &     - hawk    / Rhead**4.0d0
2351 c!-------------------------------------------------------------------
2352 c! derivative of ecl is Gcl
2353 c! dF/dr part
2354        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2355      &           + 4.0d0 * hawk    / Rhead**5.0d0
2356 c! dF/dom1
2357        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2358 c! dF/dom2
2359        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2360 c--------------------------------------------------------------------
2361 c Polarization energy
2362 c Epol
2363        MomoFac2 = (1.0d0 - chi2 * sqom1)
2364        RR2  = R2 * R2 / MomoFac2
2365        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2366        fgb2 = sqrt(RR2  + a12sq * ee2)
2367        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2368 c!       epol = 0.0d0
2369 c! derivative of Epol is Gpol...
2370        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2371      &          / (fgb2 ** 5.0d0)
2372        dFGBdR2 = ( (R2 / MomoFac2)
2373      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2374      &        / (2.0d0 * fgb2)
2375        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2376      &          * (2.0d0 - 0.5d0 * ee2) )
2377      &          / (2.0d0 * fgb2)
2378        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2379 c!       dPOLdR2 = 0.0d0
2380        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2381 c!       dPOLdOM1 = 0.0d0
2382        dPOLdOM2 = 0.0d0
2383 c!-------------------------------------------------------------------
2384 c! Elj
2385        pom = (pis / Rhead)**6.0d0
2386        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2387 c! derivative of Elj is Glj
2388        dGLJdR = 4.0d0 * eps_head
2389      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2390      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2391 c!-------------------------------------------------------------------
2392 c! Return the results
2393 c! (see comments in Eqq)
2394        DO k = 1, 3
2395         erhead(k) = Rhead_distance(k)/Rhead
2396         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2397        END DO
2398        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2399        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2400        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2401        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2402        facd1 = d1 * vbld_inv(i+nres)
2403        facd2 = d2 * vbld_inv(j+nres)
2404        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2405
2406        DO k = 1, 3
2407         condor = (erhead_tail(k,2)
2408      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2409
2410         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2411         gvdwx(k,i) = gvdwx(k,i)
2412      &             - dGCLdR * pom
2413      &             - dPOLdR2 * (erhead_tail(k,2)
2414      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2415      &             - dGLJdR * pom
2416
2417         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2418         gvdwx(k,j) = gvdwx(k,j)
2419      &             + dGCLdR * pom
2420      &             + dPOLdR2 * condor
2421      &             + dGLJdR * pom
2422
2423
2424         gvdwc(k,i) = gvdwc(k,i)
2425      &             - dGCLdR * erhead(k)
2426      &             - dPOLdR2 * erhead_tail(k,2)
2427      &             - dGLJdR * erhead(k)
2428
2429         gvdwc(k,j) = gvdwc(k,j)
2430      &             + dGCLdR * erhead(k)
2431      &             + dPOLdR2 * erhead_tail(k,2)
2432      &             + dGLJdR * erhead(k)
2433
2434        END DO
2435        RETURN
2436       END SUBROUTINE edq
2437
2438
2439 C--------------------------------------------------------------------
2440
2441
2442       SUBROUTINE edd(ECL)
2443        IMPLICIT NONE
2444        INCLUDE 'DIMENSIONS'
2445        INCLUDE 'sizesclu.dat'
2446        INCLUDE 'COMMON.CALC'
2447        INCLUDE 'COMMON.CHAIN'
2448        INCLUDE 'COMMON.CONTROL'
2449        INCLUDE 'COMMON.DERIV'
2450        INCLUDE 'COMMON.EMP'
2451        INCLUDE 'COMMON.GEO'
2452        INCLUDE 'COMMON.INTERACT'
2453        INCLUDE 'COMMON.IOUNITS'
2454        INCLUDE 'COMMON.LOCAL'
2455        INCLUDE 'COMMON.NAMES'
2456        INCLUDE 'COMMON.VAR'
2457        double precision scalar
2458 c!       csig = sigiso(itypi,itypj)
2459        w1 = wqdip(1,itypi,itypj)
2460        w2 = wqdip(2,itypi,itypj)
2461 c!-------------------------------------------------------------------
2462 c! ECL
2463        fac = (om12 - 3.0d0 * om1 * om2)
2464        c1 = (w1 / (Rhead**3.0d0)) * fac
2465        c2 = (w2 / Rhead ** 6.0d0)
2466      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2467        ECL = c1 - c2
2468 c!       write (*,*) "w1 = ", w1
2469 c!       write (*,*) "w2 = ", w2
2470 c!       write (*,*) "om1 = ", om1
2471 c!       write (*,*) "om2 = ", om2
2472 c!       write (*,*) "om12 = ", om12
2473 c!       write (*,*) "fac = ", fac
2474 c!       write (*,*) "c1 = ", c1
2475 c!       write (*,*) "c2 = ", c2
2476 c!       write (*,*) "Ecl = ", Ecl
2477 c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
2478 c!       write (*,*) "c2_2 = ",
2479 c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2480 c!-------------------------------------------------------------------
2481 c! dervative of ECL is GCL...
2482 c! dECL/dr
2483        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
2484        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)
2485      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
2486        dGCLdR = c1 - c2
2487 c! dECL/dom1
2488        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
2489        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2490      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
2491        dGCLdOM1 = c1 - c2
2492 c! dECL/dom2
2493        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
2494        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2495      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
2496        dGCLdOM2 = c1 - c2
2497 c! dECL/dom12
2498        c1 = w1 / (Rhead ** 3.0d0)
2499        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
2500        dGCLdOM12 = c1 - c2
2501 c!-------------------------------------------------------------------
2502 c! Return the results
2503 c! (see comments in Eqq)
2504        DO k= 1, 3
2505         erhead(k) = Rhead_distance(k)/Rhead
2506        END DO
2507        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2508        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2509        facd1 = d1 * vbld_inv(i+nres)
2510        facd2 = d2 * vbld_inv(j+nres)
2511        DO k = 1, 3
2512
2513         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2514         gvdwx(k,i) = gvdwx(k,i)
2515      &             - dGCLdR * pom
2516         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2517         gvdwx(k,j) = gvdwx(k,j)
2518      &             + dGCLdR * pom
2519
2520         gvdwc(k,i) = gvdwc(k,i)
2521      &             - dGCLdR * erhead(k)
2522         gvdwc(k,j) = gvdwc(k,j)
2523      &             + dGCLdR * erhead(k)
2524        END DO
2525        RETURN
2526       END SUBROUTINE edd
2527
2528
2529 c!-------------------------------------------------------------------
2530
2531
2532       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
2533        IMPLICIT NONE
2534 c! maxres
2535        INCLUDE 'DIMENSIONS'
2536        INCLUDE 'sizesclu.dat'
2537 c! itypi, itypj, i, j, k, l, chead,
2538        INCLUDE 'COMMON.CALC'
2539 c! c, nres, dc_norm
2540        INCLUDE 'COMMON.CHAIN'
2541 c! gradc, gradx
2542        INCLUDE 'COMMON.DERIV'
2543 c! electrostatic gradients-specific variables
2544        INCLUDE 'COMMON.EMP'
2545 c! wquad, dhead, alphiso, alphasur, rborn, epsintab
2546        INCLUDE 'COMMON.INTERACT'
2547 c! io for debug, disable it in final builds
2548        INCLUDE 'COMMON.IOUNITS'
2549 c!-------------------------------------------------------------------
2550 c! Variable Init
2551
2552 c! what amino acid is the aminoacid j'th?
2553        itypj = itype(j)
2554 c! 1/(Gas Constant * Thermostate temperature) = BetaTT
2555 c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
2556        BetaTT = 1.0d0 / (298 * 1.987d-3)
2557 c! Gay-berne var's
2558        sig0ij = sigma( itypi,itypj )
2559        chi1   = chi( itypi, itypj )
2560        chi2   = chi( itypj, itypi )
2561        chi12  = chi1 * chi2
2562        chip1  = chipp( itypi, itypj )
2563        chip2  = chipp( itypj, itypi )
2564        chip12 = chip1 * chip2
2565 c!       write (2,*) "elgrad types",itypi,itypj,
2566 c!     & " chi1",chi1," chi2",chi2," chi12",chi12,
2567 c!     &  " chip1",chip1," chip2",chip2," chip12",chip12
2568 c! not used by momo potential, but needed by sc_angular which is shared
2569 c! by all energy_potential subroutines
2570        alf1   = 0.0d0
2571        alf2   = 0.0d0
2572        alf12  = 0.0d0
2573 c! location, location, location
2574        xj  = c( 1, nres+j ) - xi
2575        yj  = c( 2, nres+j ) - yi
2576        zj  = c( 3, nres+j ) - zi
2577        dxj = dc_norm( 1, nres+j )
2578        dyj = dc_norm( 2, nres+j )
2579        dzj = dc_norm( 3, nres+j )
2580 c! distance from center of chain(?) to polar/charged head
2581 c!       write (*,*) "istate = ", 1
2582 c!       write (*,*) "ii = ", 1
2583 c!       write (*,*) "jj = ", 1
2584        d1 = dhead(1, 1, itypi, itypj)
2585        d2 = dhead(2, 1, itypi, itypj)
2586 c! ai*aj from Fgb
2587        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
2588 c!       a12sq = a12sq * a12sq
2589 c! charge of amino acid itypi is...
2590        Qi  = icharge(itypi)
2591        Qj  = icharge(itypj)
2592        Qij = Qi * Qj
2593 c! chis1,2,12
2594        chis1 = chis(itypi,itypj)
2595        chis2 = chis(itypj,itypi)
2596        chis12 = chis1 * chis2
2597        sig1 = sigmap1(itypi,itypj)
2598        sig2 = sigmap2(itypi,itypj)
2599 c!       write (*,*) "sig1 = ", sig1
2600 c!       write (*,*) "sig2 = ", sig2
2601 c! alpha factors from Fcav/Gcav
2602        b1 = alphasur(1,itypi,itypj)
2603        b2 = alphasur(2,itypi,itypj)
2604        b3 = alphasur(3,itypi,itypj)
2605        b4 = alphasur(4,itypi,itypj)
2606 c! used to determine whether we want to do quadrupole calculations
2607        wqd = wquad(itypi, itypj)
2608 c! used by Fgb
2609        eps_in = epsintab(itypi,itypj)
2610        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
2611 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
2612 c!-------------------------------------------------------------------
2613 c! tail location and distance calculations
2614        Rtail = 0.0d0
2615        DO k = 1, 3
2616         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
2617         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
2618        END DO
2619 c! tail distances will be themselves usefull elswhere
2620 c1 (in Gcav, for example)
2621        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
2622        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
2623        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
2624        Rtail = dsqrt(
2625      &     (Rtail_distance(1)*Rtail_distance(1))
2626      &   + (Rtail_distance(2)*Rtail_distance(2))
2627      &   + (Rtail_distance(3)*Rtail_distance(3)))
2628 c!-------------------------------------------------------------------
2629 c! Calculate location and distance between polar heads
2630 c! distance between heads
2631 c! for each one of our three dimensional space...
2632        DO k = 1,3
2633 c! location of polar head is computed by taking hydrophobic centre
2634 c! and moving by a d1 * dc_norm vector
2635 c! see unres publications for very informative images
2636         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
2637         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
2638 c! distance
2639 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
2640 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
2641         Rhead_distance(k) = chead(k,2) - chead(k,1)
2642        END DO
2643 c! pitagoras (root of sum of squares)
2644        Rhead = dsqrt(
2645      &     (Rhead_distance(1)*Rhead_distance(1))
2646      &   + (Rhead_distance(2)*Rhead_distance(2))
2647      &   + (Rhead_distance(3)*Rhead_distance(3)))
2648 c!-------------------------------------------------------------------
2649 c! zero everything that should be zero'ed
2650        Egb = 0.0d0
2651        ECL = 0.0d0
2652        Elj = 0.0d0
2653        Equad = 0.0d0
2654        Epol = 0.0d0
2655        eheadtail = 0.0d0
2656        dGCLdOM1 = 0.0d0
2657        dGCLdOM2 = 0.0d0
2658        dGCLdOM12 = 0.0d0
2659        dPOLdOM1 = 0.0d0
2660        dPOLdOM2 = 0.0d0
2661        RETURN
2662       END SUBROUTINE elgrad_init
2663 c!-------------------------------------------------------------------
2664       subroutine sc_angular
2665 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2666 C om12. Called by ebp, egb, and egbv.
2667       implicit none
2668       include 'COMMON.CALC'
2669       include 'COMMON.IOUNITS'
2670       erij(1)=xj*rij
2671       erij(2)=yj*rij
2672       erij(3)=zj*rij
2673       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2674       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2675       om12=dxi*dxj+dyi*dyj+dzi*dzj
2676 c!      om1    = 0.0d0
2677 c!      om2    = 0.0d0
2678 c!      om12   = 0.0d0
2679       chiom12=chi12*om12
2680 C Calculate eps1(om12) and its derivative in om12
2681       faceps1=1.0D0-om12*chiom12
2682       faceps1_inv=1.0D0/faceps1
2683       eps1=dsqrt(faceps1_inv)
2684 c      write (2,*) "chi1",chi1," chi2",chi2," chi12",chi12
2685 c      write (2,*) "fsceps1",faceps1," faceps1_inv",faceps1_inv,
2686 c     & " eps1",eps1
2687 C Following variable is eps1*deps1/dom12
2688       eps1_om12=faceps1_inv*chiom12
2689 c diagnostics only
2690 c      faceps1_inv=om12
2691 c      eps1=om12
2692 c      eps1_om12=1.0d0
2693 c      write (iout,*) "om12",om12," eps1",eps1
2694 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2695 C and om12.
2696       om1om2=om1*om2
2697       chiom1=chi1*om1
2698       chiom2=chi2*om2
2699       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2700       sigsq=1.0D0-facsig*faceps1_inv
2701 c      write (2,*) "om1",om1," om2",om2," om1om2",om1om2,
2702 c     & " chiom1",chiom1,
2703 c     &  " chiom2",chiom2," facsig",facsig," sigsq",sigsq
2704       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2705       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2706       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2707 c diagnostics only
2708 c      sigsq=1.0d0
2709 c      sigsq_om1=0.0d0
2710 c      sigsq_om2=0.0d0
2711 c      sigsq_om12=0.0d0
2712 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2713 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2714 c     &    " eps1",eps1
2715 C Calculate eps2 and its derivatives in om1, om2, and om12.
2716       chipom1=chip1*om1
2717       chipom2=chip2*om2
2718       chipom12=chip12*om12
2719       facp=1.0D0-om12*chipom12
2720       facp_inv=1.0D0/facp
2721       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2722 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2723 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2724 C Following variable is the square root of eps2
2725       eps2rt=1.0D0-facp1*facp_inv
2726 C Following three variables are the derivatives of the square root of eps
2727 C in om1, om2, and om12.
2728       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2729       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2730       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2731 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2732 c! Note that THIS is 0 in emomo, so we should probably move it out of sc_angular
2733 c! Or frankly, we should restructurize the whole energy section
2734       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2735 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2736 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2737 c     &  " eps2rt_om12",eps2rt_om12
2738 C Calculate whole angle-dependent part of epsilon and contributions
2739 C to its derivatives
2740       return
2741       end
2742 C----------------------------------------------------------------------------
2743 C----------------------------------------------------------------------------
2744       subroutine sc_grad
2745       implicit real*8 (a-h,o-z)
2746       include 'DIMENSIONS'
2747       include 'sizesclu.dat'
2748       include 'COMMON.CHAIN'
2749       include 'COMMON.DERIV'
2750       include 'COMMON.CALC'
2751       double precision dcosom1(3),dcosom2(3)
2752       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2753       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2754       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2755      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2756       do k=1,3
2757         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2758         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2759       enddo
2760       do k=1,3
2761         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2762       enddo
2763       do k=1,3
2764         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2765      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2766      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2767         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2768      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2769      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2770       enddo
2771 C
2772 C Calculate the components of the gradient in DC and X
2773 C
2774       do k=i,j-1
2775         do l=1,3
2776           gvdwc(l,k)=gvdwc(l,k)+gg(l)
2777         enddo
2778       enddo
2779       return
2780       end
2781 c------------------------------------------------------------------------------
2782       subroutine vec_and_deriv
2783       implicit real*8 (a-h,o-z)
2784       include 'DIMENSIONS'
2785       include 'sizesclu.dat'
2786       include 'COMMON.IOUNITS'
2787       include 'COMMON.GEO'
2788       include 'COMMON.VAR'
2789       include 'COMMON.LOCAL'
2790       include 'COMMON.CHAIN'
2791       include 'COMMON.VECTORS'
2792       include 'COMMON.DERIV'
2793       include 'COMMON.INTERACT'
2794       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2795 C Compute the local reference systems. For reference system (i), the
2796 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2797 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2798       do i=1,nres-1
2799 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
2800           if (i.eq.nres-1) then
2801 C Case of the last full residue
2802 C Compute the Z-axis
2803             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2804             costh=dcos(pi-theta(nres))
2805             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2806             do k=1,3
2807               uz(k,i)=fac*uz(k,i)
2808             enddo
2809             if (calc_grad) then
2810 C Compute the derivatives of uz
2811             uzder(1,1,1)= 0.0d0
2812             uzder(2,1,1)=-dc_norm(3,i-1)
2813             uzder(3,1,1)= dc_norm(2,i-1)
2814             uzder(1,2,1)= dc_norm(3,i-1)
2815             uzder(2,2,1)= 0.0d0
2816             uzder(3,2,1)=-dc_norm(1,i-1)
2817             uzder(1,3,1)=-dc_norm(2,i-1)
2818             uzder(2,3,1)= dc_norm(1,i-1)
2819             uzder(3,3,1)= 0.0d0
2820             uzder(1,1,2)= 0.0d0
2821             uzder(2,1,2)= dc_norm(3,i)
2822             uzder(3,1,2)=-dc_norm(2,i)
2823             uzder(1,2,2)=-dc_norm(3,i)
2824             uzder(2,2,2)= 0.0d0
2825             uzder(3,2,2)= dc_norm(1,i)
2826             uzder(1,3,2)= dc_norm(2,i)
2827             uzder(2,3,2)=-dc_norm(1,i)
2828             uzder(3,3,2)= 0.0d0
2829             endif
2830 C Compute the Y-axis
2831             facy=fac
2832             do k=1,3
2833               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2834             enddo
2835             if (calc_grad) then
2836 C Compute the derivatives of uy
2837             do j=1,3
2838               do k=1,3
2839                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2840      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2841                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2842               enddo
2843               uyder(j,j,1)=uyder(j,j,1)-costh
2844               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2845             enddo
2846             do j=1,2
2847               do k=1,3
2848                 do l=1,3
2849                   uygrad(l,k,j,i)=uyder(l,k,j)
2850                   uzgrad(l,k,j,i)=uzder(l,k,j)
2851                 enddo
2852               enddo
2853             enddo
2854             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2855             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2856             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2857             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2858             endif
2859           else
2860 C Other residues
2861 C Compute the Z-axis
2862             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2863             costh=dcos(pi-theta(i+2))
2864             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2865             do k=1,3
2866               uz(k,i)=fac*uz(k,i)
2867             enddo
2868             if (calc_grad) then
2869 C Compute the derivatives of uz
2870             uzder(1,1,1)= 0.0d0
2871             uzder(2,1,1)=-dc_norm(3,i+1)
2872             uzder(3,1,1)= dc_norm(2,i+1)
2873             uzder(1,2,1)= dc_norm(3,i+1)
2874             uzder(2,2,1)= 0.0d0
2875             uzder(3,2,1)=-dc_norm(1,i+1)
2876             uzder(1,3,1)=-dc_norm(2,i+1)
2877             uzder(2,3,1)= dc_norm(1,i+1)
2878             uzder(3,3,1)= 0.0d0
2879             uzder(1,1,2)= 0.0d0
2880             uzder(2,1,2)= dc_norm(3,i)
2881             uzder(3,1,2)=-dc_norm(2,i)
2882             uzder(1,2,2)=-dc_norm(3,i)
2883             uzder(2,2,2)= 0.0d0
2884             uzder(3,2,2)= dc_norm(1,i)
2885             uzder(1,3,2)= dc_norm(2,i)
2886             uzder(2,3,2)=-dc_norm(1,i)
2887             uzder(3,3,2)= 0.0d0
2888             endif
2889 C Compute the Y-axis
2890             facy=fac
2891             do k=1,3
2892               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2893             enddo
2894             if (calc_grad) then
2895 C Compute the derivatives of uy
2896             do j=1,3
2897               do k=1,3
2898                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2899      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2900                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2901               enddo
2902               uyder(j,j,1)=uyder(j,j,1)-costh
2903               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2904             enddo
2905             do j=1,2
2906               do k=1,3
2907                 do l=1,3
2908                   uygrad(l,k,j,i)=uyder(l,k,j)
2909                   uzgrad(l,k,j,i)=uzder(l,k,j)
2910                 enddo
2911               enddo
2912             enddo
2913             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2914             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2915             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2916             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2917           endif
2918           endif
2919       enddo
2920       if (calc_grad) then
2921       do i=1,nres-1
2922         vbld_inv_temp(1)=vbld_inv(i+1)
2923         if (i.lt.nres-1) then
2924           vbld_inv_temp(2)=vbld_inv(i+2)
2925         else
2926           vbld_inv_temp(2)=vbld_inv(i)
2927         endif
2928         do j=1,2
2929           do k=1,3
2930             do l=1,3
2931               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2932               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2933             enddo
2934           enddo
2935         enddo
2936       enddo
2937       endif
2938       return
2939       end
2940 C-----------------------------------------------------------------------------
2941       subroutine vec_and_deriv_test
2942       implicit real*8 (a-h,o-z)
2943       include 'DIMENSIONS'
2944       include 'sizesclu.dat'
2945       include 'COMMON.IOUNITS'
2946       include 'COMMON.GEO'
2947       include 'COMMON.VAR'
2948       include 'COMMON.LOCAL'
2949       include 'COMMON.CHAIN'
2950       include 'COMMON.VECTORS'
2951       dimension uyder(3,3,2),uzder(3,3,2)
2952 C Compute the local reference systems. For reference system (i), the
2953 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2954 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2955       do i=1,nres-1
2956           if (i.eq.nres-1) then
2957 C Case of the last full residue
2958 C Compute the Z-axis
2959             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2960             costh=dcos(pi-theta(nres))
2961             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2962 c            write (iout,*) 'fac',fac,
2963 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
2964             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
2965             do k=1,3
2966               uz(k,i)=fac*uz(k,i)
2967             enddo
2968 C Compute the derivatives of uz
2969             uzder(1,1,1)= 0.0d0
2970             uzder(2,1,1)=-dc_norm(3,i-1)
2971             uzder(3,1,1)= dc_norm(2,i-1)
2972             uzder(1,2,1)= dc_norm(3,i-1)
2973             uzder(2,2,1)= 0.0d0
2974             uzder(3,2,1)=-dc_norm(1,i-1)
2975             uzder(1,3,1)=-dc_norm(2,i-1)
2976             uzder(2,3,1)= dc_norm(1,i-1)
2977             uzder(3,3,1)= 0.0d0
2978             uzder(1,1,2)= 0.0d0
2979             uzder(2,1,2)= dc_norm(3,i)
2980             uzder(3,1,2)=-dc_norm(2,i)
2981             uzder(1,2,2)=-dc_norm(3,i)
2982             uzder(2,2,2)= 0.0d0
2983             uzder(3,2,2)= dc_norm(1,i)
2984             uzder(1,3,2)= dc_norm(2,i)
2985             uzder(2,3,2)=-dc_norm(1,i)
2986             uzder(3,3,2)= 0.0d0
2987 C Compute the Y-axis
2988             do k=1,3
2989               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2990             enddo
2991             facy=fac
2992             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
2993      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
2994      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
2995             do k=1,3
2996 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2997               uy(k,i)=
2998 c     &        facy*(
2999      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
3000      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
3001 c     &        )
3002             enddo
3003 c            write (iout,*) 'facy',facy,
3004 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3005             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3006             do k=1,3
3007               uy(k,i)=facy*uy(k,i)
3008             enddo
3009 C Compute the derivatives of uy
3010             do j=1,3
3011               do k=1,3
3012                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
3013      &                        -dc_norm(k,i)*dc_norm(j,i-1)
3014                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3015               enddo
3016 c              uyder(j,j,1)=uyder(j,j,1)-costh
3017 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
3018               uyder(j,j,1)=uyder(j,j,1)
3019      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
3020               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
3021      &          +uyder(j,j,2)
3022             enddo
3023             do j=1,2
3024               do k=1,3
3025                 do l=1,3
3026                   uygrad(l,k,j,i)=uyder(l,k,j)
3027                   uzgrad(l,k,j,i)=uzder(l,k,j)
3028                 enddo
3029               enddo
3030             enddo
3031             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3032             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3033             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3034             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3035           else
3036 C Other residues
3037 C Compute the Z-axis
3038             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
3039             costh=dcos(pi-theta(i+2))
3040             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3041             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
3042             do k=1,3
3043               uz(k,i)=fac*uz(k,i)
3044             enddo
3045 C Compute the derivatives of uz
3046             uzder(1,1,1)= 0.0d0
3047             uzder(2,1,1)=-dc_norm(3,i+1)
3048             uzder(3,1,1)= dc_norm(2,i+1)
3049             uzder(1,2,1)= dc_norm(3,i+1)
3050             uzder(2,2,1)= 0.0d0
3051             uzder(3,2,1)=-dc_norm(1,i+1)
3052             uzder(1,3,1)=-dc_norm(2,i+1)
3053             uzder(2,3,1)= dc_norm(1,i+1)
3054             uzder(3,3,1)= 0.0d0
3055             uzder(1,1,2)= 0.0d0
3056             uzder(2,1,2)= dc_norm(3,i)
3057             uzder(3,1,2)=-dc_norm(2,i)
3058             uzder(1,2,2)=-dc_norm(3,i)
3059             uzder(2,2,2)= 0.0d0
3060             uzder(3,2,2)= dc_norm(1,i)
3061             uzder(1,3,2)= dc_norm(2,i)
3062             uzder(2,3,2)=-dc_norm(1,i)
3063             uzder(3,3,2)= 0.0d0
3064 C Compute the Y-axis
3065             facy=fac
3066             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
3067      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
3068      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
3069             do k=1,3
3070 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3071               uy(k,i)=
3072 c     &        facy*(
3073      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
3074      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
3075 c     &        )
3076             enddo
3077 c            write (iout,*) 'facy',facy,
3078 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3079             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
3080             do k=1,3
3081               uy(k,i)=facy*uy(k,i)
3082             enddo
3083 C Compute the derivatives of uy
3084             do j=1,3
3085               do k=1,3
3086                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
3087      &                        -dc_norm(k,i)*dc_norm(j,i+1)
3088                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3089               enddo
3090 c              uyder(j,j,1)=uyder(j,j,1)-costh
3091 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
3092               uyder(j,j,1)=uyder(j,j,1)
3093      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
3094               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
3095      &          +uyder(j,j,2)
3096             enddo
3097             do j=1,2
3098               do k=1,3
3099                 do l=1,3
3100                   uygrad(l,k,j,i)=uyder(l,k,j)
3101                   uzgrad(l,k,j,i)=uzder(l,k,j)
3102                 enddo
3103               enddo
3104             enddo
3105             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3106             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3107             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3108             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3109           endif
3110       enddo
3111       do i=1,nres-1
3112         do j=1,2
3113           do k=1,3
3114             do l=1,3
3115               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
3116               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
3117             enddo
3118           enddo
3119         enddo
3120       enddo
3121       return
3122       end
3123 C-----------------------------------------------------------------------------
3124       subroutine check_vecgrad
3125       implicit real*8 (a-h,o-z)
3126       include 'DIMENSIONS'
3127       include 'sizesclu.dat'
3128       include 'COMMON.IOUNITS'
3129       include 'COMMON.GEO'
3130       include 'COMMON.VAR'
3131       include 'COMMON.LOCAL'
3132       include 'COMMON.CHAIN'
3133       include 'COMMON.VECTORS'
3134       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
3135       dimension uyt(3,maxres),uzt(3,maxres)
3136       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
3137       double precision delta /1.0d-7/
3138       call vec_and_deriv
3139 cd      do i=1,nres
3140 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
3141 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
3142 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
3143 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
3144 cd     &     (dc_norm(if90,i),if90=1,3)
3145 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
3146 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
3147 cd          write(iout,'(a)')
3148 cd      enddo
3149       do i=1,nres
3150         do j=1,2
3151           do k=1,3
3152             do l=1,3
3153               uygradt(l,k,j,i)=uygrad(l,k,j,i)
3154               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
3155             enddo
3156           enddo
3157         enddo
3158       enddo
3159       call vec_and_deriv
3160       do i=1,nres
3161         do j=1,3
3162           uyt(j,i)=uy(j,i)
3163           uzt(j,i)=uz(j,i)
3164         enddo
3165       enddo
3166       do i=1,nres
3167 cd        write (iout,*) 'i=',i
3168         do k=1,3
3169           erij(k)=dc_norm(k,i)
3170         enddo
3171         do j=1,3
3172           do k=1,3
3173             dc_norm(k,i)=erij(k)
3174           enddo
3175           dc_norm(j,i)=dc_norm(j,i)+delta
3176 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
3177 c          do k=1,3
3178 c            dc_norm(k,i)=dc_norm(k,i)/fac
3179 c          enddo
3180 c          write (iout,*) (dc_norm(k,i),k=1,3)
3181 c          write (iout,*) (erij(k),k=1,3)
3182           call vec_and_deriv
3183           do k=1,3
3184             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
3185             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
3186             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
3187             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
3188           enddo
3189 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3190 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
3191 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
3192         enddo
3193         do k=1,3
3194           dc_norm(k,i)=erij(k)
3195         enddo
3196 cd        do k=1,3
3197 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3198 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
3199 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
3200 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
3201 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
3202 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
3203 cd          write (iout,'(a)')
3204 cd        enddo
3205       enddo
3206       return
3207       end
3208 C--------------------------------------------------------------------------
3209       subroutine set_matrices
3210       implicit real*8 (a-h,o-z)
3211       include 'DIMENSIONS'
3212       include 'sizesclu.dat'
3213       include 'COMMON.IOUNITS'
3214       include 'COMMON.GEO'
3215       include 'COMMON.VAR'
3216       include 'COMMON.LOCAL'
3217       include 'COMMON.CHAIN'
3218       include 'COMMON.DERIV'
3219       include 'COMMON.INTERACT'
3220       include 'COMMON.CONTACTS'
3221       include 'COMMON.TORSION'
3222       include 'COMMON.VECTORS'
3223       include 'COMMON.FFIELD'
3224       double precision auxvec(2),auxmat(2,2)
3225 C
3226 C Compute the virtual-bond-torsional-angle dependent quantities needed
3227 C to calculate the el-loc multibody terms of various order.
3228 C
3229       do i=3,nres+1
3230         if (i .lt. nres+1) then
3231           sin1=dsin(phi(i))
3232           cos1=dcos(phi(i))
3233           sintab(i-2)=sin1
3234           costab(i-2)=cos1
3235           obrot(1,i-2)=cos1
3236           obrot(2,i-2)=sin1
3237           sin2=dsin(2*phi(i))
3238           cos2=dcos(2*phi(i))
3239           sintab2(i-2)=sin2
3240           costab2(i-2)=cos2
3241           obrot2(1,i-2)=cos2
3242           obrot2(2,i-2)=sin2
3243           Ug(1,1,i-2)=-cos1
3244           Ug(1,2,i-2)=-sin1
3245           Ug(2,1,i-2)=-sin1
3246           Ug(2,2,i-2)= cos1
3247           Ug2(1,1,i-2)=-cos2
3248           Ug2(1,2,i-2)=-sin2
3249           Ug2(2,1,i-2)=-sin2
3250           Ug2(2,2,i-2)= cos2
3251         else
3252           costab(i-2)=1.0d0
3253           sintab(i-2)=0.0d0
3254           obrot(1,i-2)=1.0d0
3255           obrot(2,i-2)=0.0d0
3256           obrot2(1,i-2)=0.0d0
3257           obrot2(2,i-2)=0.0d0
3258           Ug(1,1,i-2)=1.0d0
3259           Ug(1,2,i-2)=0.0d0
3260           Ug(2,1,i-2)=0.0d0
3261           Ug(2,2,i-2)=1.0d0
3262           Ug2(1,1,i-2)=0.0d0
3263           Ug2(1,2,i-2)=0.0d0
3264           Ug2(2,1,i-2)=0.0d0
3265           Ug2(2,2,i-2)=0.0d0
3266         endif
3267         if (i .gt. 3 .and. i .lt. nres+1) then
3268           obrot_der(1,i-2)=-sin1
3269           obrot_der(2,i-2)= cos1
3270           Ugder(1,1,i-2)= sin1
3271           Ugder(1,2,i-2)=-cos1
3272           Ugder(2,1,i-2)=-cos1
3273           Ugder(2,2,i-2)=-sin1
3274           dwacos2=cos2+cos2
3275           dwasin2=sin2+sin2
3276           obrot2_der(1,i-2)=-dwasin2
3277           obrot2_der(2,i-2)= dwacos2
3278           Ug2der(1,1,i-2)= dwasin2
3279           Ug2der(1,2,i-2)=-dwacos2
3280           Ug2der(2,1,i-2)=-dwacos2
3281           Ug2der(2,2,i-2)=-dwasin2
3282         else
3283           obrot_der(1,i-2)=0.0d0
3284           obrot_der(2,i-2)=0.0d0
3285           Ugder(1,1,i-2)=0.0d0
3286           Ugder(1,2,i-2)=0.0d0
3287           Ugder(2,1,i-2)=0.0d0
3288           Ugder(2,2,i-2)=0.0d0
3289           obrot2_der(1,i-2)=0.0d0
3290           obrot2_der(2,i-2)=0.0d0
3291           Ug2der(1,1,i-2)=0.0d0
3292           Ug2der(1,2,i-2)=0.0d0
3293           Ug2der(2,1,i-2)=0.0d0
3294           Ug2der(2,2,i-2)=0.0d0
3295         endif
3296         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3297           iti = itortyp(itype(i-2))
3298         else
3299           iti=ntortyp+1
3300         endif
3301         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3302           iti1 = itortyp(itype(i-1))
3303         else
3304           iti1=ntortyp+1
3305         endif
3306 cd        write (iout,*) '*******i',i,' iti1',iti
3307 cd        write (iout,*) 'b1',b1(:,iti)
3308 cd        write (iout,*) 'b2',b2(:,iti)
3309 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3310         if (i .gt. iatel_s+2) then
3311           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
3312           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
3313           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3314           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3315           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3316           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3317           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3318         else
3319           do k=1,2
3320             Ub2(k,i-2)=0.0d0
3321             Ctobr(k,i-2)=0.0d0
3322             Dtobr2(k,i-2)=0.0d0
3323             do l=1,2
3324               EUg(l,k,i-2)=0.0d0
3325               CUg(l,k,i-2)=0.0d0
3326               DUg(l,k,i-2)=0.0d0
3327               DtUg2(l,k,i-2)=0.0d0
3328             enddo
3329           enddo
3330         endif
3331         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
3332         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
3333         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3334         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3335         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3336         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3337         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3338         do k=1,2
3339           muder(k,i-2)=Ub2der(k,i-2)
3340         enddo
3341         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3342           iti1 = itortyp(itype(i-1))
3343         else
3344           iti1=ntortyp+1
3345         endif
3346         do k=1,2
3347           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
3348         enddo
3349 C Vectors and matrices dependent on a single virtual-bond dihedral.
3350         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
3351         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3352         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3353         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3354         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3355         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3356         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3357         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3358         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3359 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
3360 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
3361       enddo
3362 C Matrices dependent on two consecutive virtual-bond dihedrals.
3363 C The order of matrices is from left to right.
3364       do i=2,nres-1
3365         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3366         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3367         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3368         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3369         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3370         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3371         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3372         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3373       enddo
3374 cd      do i=1,nres
3375 cd        iti = itortyp(itype(i))
3376 cd        write (iout,*) i
3377 cd        do j=1,2
3378 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3379 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3380 cd        enddo
3381 cd      enddo
3382       return
3383       end
3384 C--------------------------------------------------------------------------
3385       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3386 C
3387 C This subroutine calculates the average interaction energy and its gradient
3388 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3389 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3390 C The potential depends both on the distance of peptide-group centers and on
3391 C the orientation of the CA-CA virtual bonds.
3392 C
3393       implicit real*8 (a-h,o-z)
3394       include 'DIMENSIONS'
3395       include 'sizesclu.dat'
3396       include 'COMMON.CONTROL'
3397       include 'COMMON.IOUNITS'
3398       include 'COMMON.GEO'
3399       include 'COMMON.VAR'
3400       include 'COMMON.LOCAL'
3401       include 'COMMON.CHAIN'
3402       include 'COMMON.DERIV'
3403       include 'COMMON.INTERACT'
3404       include 'COMMON.CONTACTS'
3405       include 'COMMON.TORSION'
3406       include 'COMMON.VECTORS'
3407       include 'COMMON.FFIELD'
3408       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3409      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3410       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3411      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3412       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
3413 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3414       double precision scal_el /0.5d0/
3415 C 12/13/98
3416 C 13-go grudnia roku pamietnego...
3417       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3418      &                   0.0d0,1.0d0,0.0d0,
3419      &                   0.0d0,0.0d0,1.0d0/
3420 cd      write(iout,*) 'In EELEC'
3421 cd      do i=1,nloctyp
3422 cd        write(iout,*) 'Type',i
3423 cd        write(iout,*) 'B1',B1(:,i)
3424 cd        write(iout,*) 'B2',B2(:,i)
3425 cd        write(iout,*) 'CC',CC(:,:,i)
3426 cd        write(iout,*) 'DD',DD(:,:,i)
3427 cd        write(iout,*) 'EE',EE(:,:,i)
3428 cd      enddo
3429 cd      call check_vecgrad
3430 cd      stop
3431       if (icheckgrad.eq.1) then
3432         do i=1,nres-1
3433           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3434           do k=1,3
3435             dc_norm(k,i)=dc(k,i)*fac
3436           enddo
3437 c          write (iout,*) 'i',i,' fac',fac
3438         enddo
3439       endif
3440       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3441      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3442      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3443 cd      if (wel_loc.gt.0.0d0) then
3444         if (icheckgrad.eq.1) then
3445         call vec_and_deriv_test
3446         else
3447         call vec_and_deriv
3448         endif
3449         call set_matrices
3450       endif
3451 cd      do i=1,nres-1
3452 cd        write (iout,*) 'i=',i
3453 cd        do k=1,3
3454 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3455 cd        enddo
3456 cd        do k=1,3
3457 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3458 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3459 cd        enddo
3460 cd      enddo
3461       num_conti_hb=0
3462       ees=0.0D0
3463       evdw1=0.0D0
3464       eel_loc=0.0d0
3465       eello_turn3=0.0d0
3466       eello_turn4=0.0d0
3467       ind=0
3468       do i=1,nres
3469         num_cont_hb(i)=0
3470       enddo
3471 cd      print '(a)','Enter EELEC'
3472 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3473       do i=1,nres
3474         gel_loc_loc(i)=0.0d0
3475         gcorr_loc(i)=0.0d0
3476       enddo
3477       do i=iatel_s,iatel_e
3478         if (itel(i).eq.0) goto 1215
3479         dxi=dc(1,i)
3480         dyi=dc(2,i)
3481         dzi=dc(3,i)
3482         dx_normi=dc_norm(1,i)
3483         dy_normi=dc_norm(2,i)
3484         dz_normi=dc_norm(3,i)
3485         xmedi=c(1,i)+0.5d0*dxi
3486         ymedi=c(2,i)+0.5d0*dyi
3487         zmedi=c(3,i)+0.5d0*dzi
3488         num_conti=0
3489 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3490         do j=ielstart(i),ielend(i)
3491           if (itel(j).eq.0) goto 1216
3492           ind=ind+1
3493           iteli=itel(i)
3494           itelj=itel(j)
3495           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3496           aaa=app(iteli,itelj)
3497           bbb=bpp(iteli,itelj)
3498 C Diagnostics only!!!
3499 c         aaa=0.0D0
3500 c         bbb=0.0D0
3501 c         ael6i=0.0D0
3502 c         ael3i=0.0D0
3503 C End diagnostics
3504           ael6i=ael6(iteli,itelj)
3505           ael3i=ael3(iteli,itelj)
3506           dxj=dc(1,j)
3507           dyj=dc(2,j)
3508           dzj=dc(3,j)
3509           dx_normj=dc_norm(1,j)
3510           dy_normj=dc_norm(2,j)
3511           dz_normj=dc_norm(3,j)
3512           xj=c(1,j)+0.5D0*dxj-xmedi
3513           yj=c(2,j)+0.5D0*dyj-ymedi
3514           zj=c(3,j)+0.5D0*dzj-zmedi
3515           rij=xj*xj+yj*yj+zj*zj
3516           rrmij=1.0D0/rij
3517           rij=dsqrt(rij)
3518           rmij=1.0D0/rij
3519           r3ij=rrmij*rmij
3520           r6ij=r3ij*r3ij
3521           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3522           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3523           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3524           fac=cosa-3.0D0*cosb*cosg
3525           ev1=aaa*r6ij*r6ij
3526 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3527           if (j.eq.i+2) ev1=scal_el*ev1
3528           ev2=bbb*r6ij
3529           fac3=ael6i*r6ij
3530           fac4=ael3i*r3ij
3531           evdwij=ev1+ev2
3532           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3533           el2=fac4*fac
3534           eesij=el1+el2
3535 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
3536 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3537           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3538           ees=ees+eesij
3539           evdw1=evdw1+evdwij
3540 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3541 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3542 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3543 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3544 C
3545 C Calculate contributions to the Cartesian gradient.
3546 C
3547 #ifdef SPLITELE
3548           facvdw=-6*rrmij*(ev1+evdwij)
3549           facel=-3*rrmij*(el1+eesij)
3550           fac1=fac
3551           erij(1)=xj*rmij
3552           erij(2)=yj*rmij
3553           erij(3)=zj*rmij
3554           if (calc_grad) then
3555 *
3556 * Radial derivatives. First process both termini of the fragment (i,j)
3557 *
3558           ggg(1)=facel*xj
3559           ggg(2)=facel*yj
3560           ggg(3)=facel*zj
3561           do k=1,3
3562             ghalf=0.5D0*ggg(k)
3563             gelc(k,i)=gelc(k,i)+ghalf
3564             gelc(k,j)=gelc(k,j)+ghalf
3565           enddo
3566 *
3567 * Loop over residues i+1 thru j-1.
3568 *
3569           do k=i+1,j-1
3570             do l=1,3
3571               gelc(l,k)=gelc(l,k)+ggg(l)
3572             enddo
3573           enddo
3574           ggg(1)=facvdw*xj
3575           ggg(2)=facvdw*yj
3576           ggg(3)=facvdw*zj
3577           do k=1,3
3578             ghalf=0.5D0*ggg(k)
3579             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3580             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3581           enddo
3582 *
3583 * Loop over residues i+1 thru j-1.
3584 *
3585           do k=i+1,j-1
3586             do l=1,3
3587               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3588             enddo
3589           enddo
3590 #else
3591           facvdw=ev1+evdwij
3592           facel=el1+eesij
3593           fac1=fac
3594           fac=-3*rrmij*(facvdw+facvdw+facel)
3595           erij(1)=xj*rmij
3596           erij(2)=yj*rmij
3597           erij(3)=zj*rmij
3598           if (calc_grad) then
3599 *
3600 * Radial derivatives. First process both termini of the fragment (i,j)
3601 *
3602           ggg(1)=fac*xj
3603           ggg(2)=fac*yj
3604           ggg(3)=fac*zj
3605           do k=1,3
3606             ghalf=0.5D0*ggg(k)
3607             gelc(k,i)=gelc(k,i)+ghalf
3608             gelc(k,j)=gelc(k,j)+ghalf
3609           enddo
3610 *
3611 * Loop over residues i+1 thru j-1.
3612 *
3613           do k=i+1,j-1
3614             do l=1,3
3615               gelc(l,k)=gelc(l,k)+ggg(l)
3616             enddo
3617           enddo
3618 #endif
3619 *
3620 * Angular part
3621 *
3622           ecosa=2.0D0*fac3*fac1+fac4
3623           fac4=-3.0D0*fac4
3624           fac3=-6.0D0*fac3
3625           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3626           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3627           do k=1,3
3628             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3629             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3630           enddo
3631 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3632 cd   &          (dcosg(k),k=1,3)
3633           do k=1,3
3634             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3635           enddo
3636           do k=1,3
3637             ghalf=0.5D0*ggg(k)
3638             gelc(k,i)=gelc(k,i)+ghalf
3639      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3640      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3641             gelc(k,j)=gelc(k,j)+ghalf
3642      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3643      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3644           enddo
3645           do k=i+1,j-1
3646             do l=1,3
3647               gelc(l,k)=gelc(l,k)+ggg(l)
3648             enddo
3649           enddo
3650           endif
3651
3652           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3653      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3654      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3655 C
3656 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3657 C   energy of a peptide unit is assumed in the form of a second-order
3658 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3659 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3660 C   are computed for EVERY pair of non-contiguous peptide groups.
3661 C
3662           if (j.lt.nres-1) then
3663             j1=j+1
3664             j2=j-1
3665           else
3666             j1=j-1
3667             j2=j-2
3668           endif
3669           kkk=0
3670           do k=1,2
3671             do l=1,2
3672               kkk=kkk+1
3673               muij(kkk)=mu(k,i)*mu(l,j)
3674             enddo
3675           enddo
3676 cd         write (iout,*) 'EELEC: i',i,' j',j
3677 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3678 cd          write(iout,*) 'muij',muij
3679           ury=scalar(uy(1,i),erij)
3680           urz=scalar(uz(1,i),erij)
3681           vry=scalar(uy(1,j),erij)
3682           vrz=scalar(uz(1,j),erij)
3683           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3684           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3685           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3686           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3687 C For diagnostics only
3688 cd          a22=1.0d0
3689 cd          a23=1.0d0
3690 cd          a32=1.0d0
3691 cd          a33=1.0d0
3692           fac=dsqrt(-ael6i)*r3ij
3693 cd          write (2,*) 'fac=',fac
3694 C For diagnostics only
3695 cd          fac=1.0d0
3696           a22=a22*fac
3697           a23=a23*fac
3698           a32=a32*fac
3699           a33=a33*fac
3700 cd          write (iout,'(4i5,4f10.5)')
3701 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3702 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3703 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
3704 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
3705 cd          write (iout,'(4f10.5)')
3706 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3707 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3708 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3709 cd           write (iout,'(2i3,9f10.5/)') i,j,
3710 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3711           if (calc_grad) then
3712 C Derivatives of the elements of A in virtual-bond vectors
3713           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3714 cd          do k=1,3
3715 cd            do l=1,3
3716 cd              erder(k,l)=0.0d0
3717 cd            enddo
3718 cd          enddo
3719           do k=1,3
3720             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3721             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3722             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3723             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3724             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3725             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3726             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3727             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3728             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3729             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3730             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3731             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3732           enddo
3733 cd          do k=1,3
3734 cd            do l=1,3
3735 cd              uryg(k,l)=0.0d0
3736 cd              urzg(k,l)=0.0d0
3737 cd              vryg(k,l)=0.0d0
3738 cd              vrzg(k,l)=0.0d0
3739 cd            enddo
3740 cd          enddo
3741 C Compute radial contributions to the gradient
3742           facr=-3.0d0*rrmij
3743           a22der=a22*facr
3744           a23der=a23*facr
3745           a32der=a32*facr
3746           a33der=a33*facr
3747 cd          a22der=0.0d0
3748 cd          a23der=0.0d0
3749 cd          a32der=0.0d0
3750 cd          a33der=0.0d0
3751           agg(1,1)=a22der*xj
3752           agg(2,1)=a22der*yj
3753           agg(3,1)=a22der*zj
3754           agg(1,2)=a23der*xj
3755           agg(2,2)=a23der*yj
3756           agg(3,2)=a23der*zj
3757           agg(1,3)=a32der*xj
3758           agg(2,3)=a32der*yj
3759           agg(3,3)=a32der*zj
3760           agg(1,4)=a33der*xj
3761           agg(2,4)=a33der*yj
3762           agg(3,4)=a33der*zj
3763 C Add the contributions coming from er
3764           fac3=-3.0d0*fac
3765           do k=1,3
3766             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3767             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3768             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3769             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3770           enddo
3771           do k=1,3
3772 C Derivatives in DC(i)
3773             ghalf1=0.5d0*agg(k,1)
3774             ghalf2=0.5d0*agg(k,2)
3775             ghalf3=0.5d0*agg(k,3)
3776             ghalf4=0.5d0*agg(k,4)
3777             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3778      &      -3.0d0*uryg(k,2)*vry)+ghalf1
3779             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3780      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
3781             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3782      &      -3.0d0*urzg(k,2)*vry)+ghalf3
3783             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3784      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
3785 C Derivatives in DC(i+1)
3786             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3787      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
3788             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3789      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
3790             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3791      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
3792             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3793      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
3794 C Derivatives in DC(j)
3795             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3796      &      -3.0d0*vryg(k,2)*ury)+ghalf1
3797             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3798      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
3799             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3800      &      -3.0d0*vryg(k,2)*urz)+ghalf3
3801             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3802      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
3803 C Derivatives in DC(j+1) or DC(nres-1)
3804             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3805      &      -3.0d0*vryg(k,3)*ury)
3806             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3807      &      -3.0d0*vrzg(k,3)*ury)
3808             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3809      &      -3.0d0*vryg(k,3)*urz)
3810             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3811      &      -3.0d0*vrzg(k,3)*urz)
3812 cd            aggi(k,1)=ghalf1
3813 cd            aggi(k,2)=ghalf2
3814 cd            aggi(k,3)=ghalf3
3815 cd            aggi(k,4)=ghalf4
3816 C Derivatives in DC(i+1)
3817 cd            aggi1(k,1)=agg(k,1)
3818 cd            aggi1(k,2)=agg(k,2)
3819 cd            aggi1(k,3)=agg(k,3)
3820 cd            aggi1(k,4)=agg(k,4)
3821 C Derivatives in DC(j)
3822 cd            aggj(k,1)=ghalf1
3823 cd            aggj(k,2)=ghalf2
3824 cd            aggj(k,3)=ghalf3
3825 cd            aggj(k,4)=ghalf4
3826 C Derivatives in DC(j+1)
3827 cd            aggj1(k,1)=0.0d0
3828 cd            aggj1(k,2)=0.0d0
3829 cd            aggj1(k,3)=0.0d0
3830 cd            aggj1(k,4)=0.0d0
3831             if (j.eq.nres-1 .and. i.lt.j-2) then
3832               do l=1,4
3833                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
3834 cd                aggj1(k,l)=agg(k,l)
3835               enddo
3836             endif
3837           enddo
3838           endif
3839 c          goto 11111
3840 C Check the loc-el terms by numerical integration
3841           acipa(1,1)=a22
3842           acipa(1,2)=a23
3843           acipa(2,1)=a32
3844           acipa(2,2)=a33
3845           a22=-a22
3846           a23=-a23
3847           do l=1,2
3848             do k=1,3
3849               agg(k,l)=-agg(k,l)
3850               aggi(k,l)=-aggi(k,l)
3851               aggi1(k,l)=-aggi1(k,l)
3852               aggj(k,l)=-aggj(k,l)
3853               aggj1(k,l)=-aggj1(k,l)
3854             enddo
3855           enddo
3856           if (j.lt.nres-1) then
3857             a22=-a22
3858             a32=-a32
3859             do l=1,3,2
3860               do k=1,3
3861                 agg(k,l)=-agg(k,l)
3862                 aggi(k,l)=-aggi(k,l)
3863                 aggi1(k,l)=-aggi1(k,l)
3864                 aggj(k,l)=-aggj(k,l)
3865                 aggj1(k,l)=-aggj1(k,l)
3866               enddo
3867             enddo
3868           else
3869             a22=-a22
3870             a23=-a23
3871             a32=-a32
3872             a33=-a33
3873             do l=1,4
3874               do k=1,3
3875                 agg(k,l)=-agg(k,l)
3876                 aggi(k,l)=-aggi(k,l)
3877                 aggi1(k,l)=-aggi1(k,l)
3878                 aggj(k,l)=-aggj(k,l)
3879                 aggj1(k,l)=-aggj1(k,l)
3880               enddo
3881             enddo
3882           endif
3883           ENDIF ! WCORR
3884 11111     continue
3885           IF (wel_loc.gt.0.0d0) THEN
3886 C Contribution to the local-electrostatic energy coming from the i-j pair
3887           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3888      &     +a33*muij(4)
3889 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3890 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3891           eel_loc=eel_loc+eel_loc_ij
3892 C Partial derivatives in virtual-bond dihedral angles gamma
3893           if (calc_grad) then
3894           if (i.gt.1)
3895      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3896      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3897      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3898           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3899      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3900      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3901 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
3902 cd          write(iout,*) 'agg  ',agg
3903 cd          write(iout,*) 'aggi ',aggi
3904 cd          write(iout,*) 'aggi1',aggi1
3905 cd          write(iout,*) 'aggj ',aggj
3906 cd          write(iout,*) 'aggj1',aggj1
3907
3908 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3909           do l=1,3
3910             ggg(l)=agg(l,1)*muij(1)+
3911      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3912           enddo
3913           do k=i+2,j2
3914             do l=1,3
3915               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3916             enddo
3917           enddo
3918 C Remaining derivatives of eello
3919           do l=1,3
3920             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3921      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3922             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3923      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3924             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3925      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3926             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3927      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3928           enddo
3929           endif
3930           ENDIF
3931           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3932 C Contributions from turns
3933             a_temp(1,1)=a22
3934             a_temp(1,2)=a23
3935             a_temp(2,1)=a32
3936             a_temp(2,2)=a33
3937             call eturn34(i,j,eello_turn3,eello_turn4)
3938           endif
3939 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3940           if (j.gt.i+1 .and. num_conti.le.maxconts) then
3941 C
3942 C Calculate the contact function. The ith column of the array JCONT will
3943 C contain the numbers of atoms that make contacts with the atom I (of numbers
3944 C greater than I). The arrays FACONT and GACONT will contain the values of
3945 C the contact function and its derivative.
3946 c           r0ij=1.02D0*rpp(iteli,itelj)
3947 c           r0ij=1.11D0*rpp(iteli,itelj)
3948             r0ij=2.20D0*rpp(iteli,itelj)
3949 c           r0ij=1.55D0*rpp(iteli,itelj)
3950             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3951             if (fcont.gt.0.0D0) then
3952               num_conti=num_conti+1
3953               if (num_conti.gt.maxconts) then
3954                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3955      &                         ' will skip next contacts for this conf.'
3956               else
3957                 jcont_hb(num_conti,i)=j
3958                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3959      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3960 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3961 C  terms.
3962                 d_cont(num_conti,i)=rij
3963 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3964 C     --- Electrostatic-interaction matrix ---
3965                 a_chuj(1,1,num_conti,i)=a22
3966                 a_chuj(1,2,num_conti,i)=a23
3967                 a_chuj(2,1,num_conti,i)=a32
3968                 a_chuj(2,2,num_conti,i)=a33
3969 C     --- Gradient of rij
3970                 do kkk=1,3
3971                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3972                 enddo
3973 c             if (i.eq.1) then
3974 c                a_chuj(1,1,num_conti,i)=-0.61d0
3975 c                a_chuj(1,2,num_conti,i)= 0.4d0
3976 c                a_chuj(2,1,num_conti,i)= 0.65d0
3977 c                a_chuj(2,2,num_conti,i)= 0.50d0
3978 c             else if (i.eq.2) then
3979 c                a_chuj(1,1,num_conti,i)= 0.0d0
3980 c                a_chuj(1,2,num_conti,i)= 0.0d0
3981 c                a_chuj(2,1,num_conti,i)= 0.0d0
3982 c                a_chuj(2,2,num_conti,i)= 0.0d0
3983 c             endif
3984 C     --- and its gradients
3985 cd                write (iout,*) 'i',i,' j',j
3986 cd                do kkk=1,3
3987 cd                write (iout,*) 'iii 1 kkk',kkk
3988 cd                write (iout,*) agg(kkk,:)
3989 cd                enddo
3990 cd                do kkk=1,3
3991 cd                write (iout,*) 'iii 2 kkk',kkk
3992 cd                write (iout,*) aggi(kkk,:)
3993 cd                enddo
3994 cd                do kkk=1,3
3995 cd                write (iout,*) 'iii 3 kkk',kkk
3996 cd                write (iout,*) aggi1(kkk,:)
3997 cd                enddo
3998 cd                do kkk=1,3
3999 cd                write (iout,*) 'iii 4 kkk',kkk
4000 cd                write (iout,*) aggj(kkk,:)
4001 cd                enddo
4002 cd                do kkk=1,3
4003 cd                write (iout,*) 'iii 5 kkk',kkk
4004 cd                write (iout,*) aggj1(kkk,:)
4005 cd                enddo
4006                 kkll=0
4007                 do k=1,2
4008                   do l=1,2
4009                     kkll=kkll+1
4010                     do m=1,3
4011                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4012                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4013                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4014                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4015                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4016 c                      do mm=1,5
4017 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
4018 c                      enddo
4019                     enddo
4020                   enddo
4021                 enddo
4022                 ENDIF
4023                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4024 C Calculate contact energies
4025                 cosa4=4.0D0*cosa
4026                 wij=cosa-3.0D0*cosb*cosg
4027                 cosbg1=cosb+cosg
4028                 cosbg2=cosb-cosg
4029 c               fac3=dsqrt(-ael6i)/r0ij**3
4030                 fac3=dsqrt(-ael6i)*r3ij
4031                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4032                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4033 c               ees0mij=0.0D0
4034                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4035                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4036 C Diagnostics. Comment out or remove after debugging!
4037 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4038 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4039 c               ees0m(num_conti,i)=0.0D0
4040 C End diagnostics.
4041 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4042 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4043                 facont_hb(num_conti,i)=fcont
4044                 if (calc_grad) then
4045 C Angular derivatives of the contact function
4046                 ees0pij1=fac3/ees0pij
4047                 ees0mij1=fac3/ees0mij
4048                 fac3p=-3.0D0*fac3*rrmij
4049                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4050                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4051 c               ees0mij1=0.0D0
4052                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4053                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4054                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4055                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4056                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4057                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4058                 ecosap=ecosa1+ecosa2
4059                 ecosbp=ecosb1+ecosb2
4060                 ecosgp=ecosg1+ecosg2
4061                 ecosam=ecosa1-ecosa2
4062                 ecosbm=ecosb1-ecosb2
4063                 ecosgm=ecosg1-ecosg2
4064 C Diagnostics
4065 c               ecosap=ecosa1
4066 c               ecosbp=ecosb1
4067 c               ecosgp=ecosg1
4068 c               ecosam=0.0D0
4069 c               ecosbm=0.0D0
4070 c               ecosgm=0.0D0
4071 C End diagnostics
4072                 fprimcont=fprimcont/rij
4073 cd              facont_hb(num_conti,i)=1.0D0
4074 C Following line is for diagnostics.
4075 cd              fprimcont=0.0D0
4076                 do k=1,3
4077                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4078                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4079                 enddo
4080                 do k=1,3
4081                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4082                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4083                 enddo
4084                 gggp(1)=gggp(1)+ees0pijp*xj
4085                 gggp(2)=gggp(2)+ees0pijp*yj
4086                 gggp(3)=gggp(3)+ees0pijp*zj
4087                 gggm(1)=gggm(1)+ees0mijp*xj
4088                 gggm(2)=gggm(2)+ees0mijp*yj
4089                 gggm(3)=gggm(3)+ees0mijp*zj
4090 C Derivatives due to the contact function
4091                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4092                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4093                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4094                 do k=1,3
4095                   ghalfp=0.5D0*gggp(k)
4096                   ghalfm=0.5D0*gggm(k)
4097                   gacontp_hb1(k,num_conti,i)=ghalfp
4098      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4099      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4100                   gacontp_hb2(k,num_conti,i)=ghalfp
4101      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4102      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4103                   gacontp_hb3(k,num_conti,i)=gggp(k)
4104                   gacontm_hb1(k,num_conti,i)=ghalfm
4105      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4106      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4107                   gacontm_hb2(k,num_conti,i)=ghalfm
4108      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4109      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4110                   gacontm_hb3(k,num_conti,i)=gggm(k)
4111                 enddo
4112                 endif
4113 C Diagnostics. Comment out or remove after debugging!
4114 cdiag           do k=1,3
4115 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4116 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4117 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4118 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4119 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4120 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4121 cdiag           enddo
4122               ENDIF ! wcorr
4123               endif  ! num_conti.le.maxconts
4124             endif  ! fcont.gt.0
4125           endif    ! j.gt.i+1
4126  1216     continue
4127         enddo ! j
4128         num_cont_hb(i)=num_conti
4129  1215   continue
4130       enddo   ! i
4131 cd      do i=1,nres
4132 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
4133 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
4134 cd      enddo
4135 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
4136 ccc      eel_loc=eel_loc+eello_turn3
4137       return
4138       end
4139 C-----------------------------------------------------------------------------
4140       subroutine eturn34(i,j,eello_turn3,eello_turn4)
4141 C Third- and fourth-order contributions from turns
4142       implicit real*8 (a-h,o-z)
4143       include 'DIMENSIONS'
4144       include 'sizesclu.dat'
4145       include 'COMMON.IOUNITS'
4146       include 'COMMON.GEO'
4147       include 'COMMON.VAR'
4148       include 'COMMON.LOCAL'
4149       include 'COMMON.CHAIN'
4150       include 'COMMON.DERIV'
4151       include 'COMMON.INTERACT'
4152       include 'COMMON.CONTACTS'
4153       include 'COMMON.TORSION'
4154       include 'COMMON.VECTORS'
4155       include 'COMMON.FFIELD'
4156       dimension ggg(3)
4157       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4158      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4159      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
4160       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4161      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
4162       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
4163       if (j.eq.i+2) then
4164 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4165 C
4166 C               Third-order contributions
4167 C
4168 C                 (i+2)o----(i+3)
4169 C                      | |
4170 C                      | |
4171 C                 (i+1)o----i
4172 C
4173 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4174 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4175         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4176         call transpose2(auxmat(1,1),auxmat1(1,1))
4177         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4178         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4179 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4180 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4181 cd     &    ' eello_turn3_num',4*eello_turn3_num
4182         if (calc_grad) then
4183 C Derivatives in gamma(i)
4184         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4185         call transpose2(auxmat2(1,1),pizda(1,1))
4186         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
4187         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4188 C Derivatives in gamma(i+1)
4189         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4190         call transpose2(auxmat2(1,1),pizda(1,1))
4191         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
4192         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4193      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4194 C Cartesian derivatives
4195         do l=1,3
4196           a_temp(1,1)=aggi(l,1)
4197           a_temp(1,2)=aggi(l,2)
4198           a_temp(2,1)=aggi(l,3)
4199           a_temp(2,2)=aggi(l,4)
4200           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4201           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4202      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4203           a_temp(1,1)=aggi1(l,1)
4204           a_temp(1,2)=aggi1(l,2)
4205           a_temp(2,1)=aggi1(l,3)
4206           a_temp(2,2)=aggi1(l,4)
4207           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4208           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4209      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4210           a_temp(1,1)=aggj(l,1)
4211           a_temp(1,2)=aggj(l,2)
4212           a_temp(2,1)=aggj(l,3)
4213           a_temp(2,2)=aggj(l,4)
4214           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4215           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4216      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4217           a_temp(1,1)=aggj1(l,1)
4218           a_temp(1,2)=aggj1(l,2)
4219           a_temp(2,1)=aggj1(l,3)
4220           a_temp(2,2)=aggj1(l,4)
4221           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4222           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4223      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4224         enddo
4225         endif
4226       else if (j.eq.i+3) then
4227 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4228 C
4229 C               Fourth-order contributions
4230 C
4231 C                 (i+3)o----(i+4)
4232 C                     /  |
4233 C               (i+2)o   |
4234 C                     \  |
4235 C                 (i+1)o----i
4236 C
4237 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4238 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
4239         iti1=itortyp(itype(i+1))
4240         iti2=itortyp(itype(i+2))
4241         iti3=itortyp(itype(i+3))
4242         call transpose2(EUg(1,1,i+1),e1t(1,1))
4243         call transpose2(Eug(1,1,i+2),e2t(1,1))
4244         call transpose2(Eug(1,1,i+3),e3t(1,1))
4245         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4246         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4247         s1=scalar2(b1(1,iti2),auxvec(1))
4248         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4249         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4250         s2=scalar2(b1(1,iti1),auxvec(1))
4251         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4252         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4253         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4254         eello_turn4=eello_turn4-(s1+s2+s3)
4255 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4256 cd     &    ' eello_turn4_num',8*eello_turn4_num
4257 C Derivatives in gamma(i)
4258         if (calc_grad) then
4259         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4260         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4261         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4262         s1=scalar2(b1(1,iti2),auxvec(1))
4263         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4264         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4265         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4266 C Derivatives in gamma(i+1)
4267         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4268         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4269         s2=scalar2(b1(1,iti1),auxvec(1))
4270         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4271         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4272         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4273         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4274 C Derivatives in gamma(i+2)
4275         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4276         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4277         s1=scalar2(b1(1,iti2),auxvec(1))
4278         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4279         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4280         s2=scalar2(b1(1,iti1),auxvec(1))
4281         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
4282         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4283         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4284         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4285 C Cartesian derivatives
4286 C Derivatives of this turn contributions in DC(i+2)
4287         if (j.lt.nres-1) then
4288           do l=1,3
4289             a_temp(1,1)=agg(l,1)
4290             a_temp(1,2)=agg(l,2)
4291             a_temp(2,1)=agg(l,3)
4292             a_temp(2,2)=agg(l,4)
4293             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4294             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4295             s1=scalar2(b1(1,iti2),auxvec(1))
4296             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4297             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4298             s2=scalar2(b1(1,iti1),auxvec(1))
4299             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4300             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4301             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4302             ggg(l)=-(s1+s2+s3)
4303             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4304           enddo
4305         endif
4306 C Remaining derivatives of this turn contribution
4307         do l=1,3
4308           a_temp(1,1)=aggi(l,1)
4309           a_temp(1,2)=aggi(l,2)
4310           a_temp(2,1)=aggi(l,3)
4311           a_temp(2,2)=aggi(l,4)
4312           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4313           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4314           s1=scalar2(b1(1,iti2),auxvec(1))
4315           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4316           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4317           s2=scalar2(b1(1,iti1),auxvec(1))
4318           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4319           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4320           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4321           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4322           a_temp(1,1)=aggi1(l,1)
4323           a_temp(1,2)=aggi1(l,2)
4324           a_temp(2,1)=aggi1(l,3)
4325           a_temp(2,2)=aggi1(l,4)
4326           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4327           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4328           s1=scalar2(b1(1,iti2),auxvec(1))
4329           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4330           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4331           s2=scalar2(b1(1,iti1),auxvec(1))
4332           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4333           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4334           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4335           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4336           a_temp(1,1)=aggj(l,1)
4337           a_temp(1,2)=aggj(l,2)
4338           a_temp(2,1)=aggj(l,3)
4339           a_temp(2,2)=aggj(l,4)
4340           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4341           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4342           s1=scalar2(b1(1,iti2),auxvec(1))
4343           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4344           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4345           s2=scalar2(b1(1,iti1),auxvec(1))
4346           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4347           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4348           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4349           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4350           a_temp(1,1)=aggj1(l,1)
4351           a_temp(1,2)=aggj1(l,2)
4352           a_temp(2,1)=aggj1(l,3)
4353           a_temp(2,2)=aggj1(l,4)
4354           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4355           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4356           s1=scalar2(b1(1,iti2),auxvec(1))
4357           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4358           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4359           s2=scalar2(b1(1,iti1),auxvec(1))
4360           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4361           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4362           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4363           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4364         enddo
4365         endif
4366       endif
4367       return
4368       end
4369 C-----------------------------------------------------------------------------
4370       subroutine vecpr(u,v,w)
4371       implicit real*8(a-h,o-z)
4372       dimension u(3),v(3),w(3)
4373       w(1)=u(2)*v(3)-u(3)*v(2)
4374       w(2)=-u(1)*v(3)+u(3)*v(1)
4375       w(3)=u(1)*v(2)-u(2)*v(1)
4376       return
4377       end
4378 C-----------------------------------------------------------------------------
4379       subroutine unormderiv(u,ugrad,unorm,ungrad)
4380 C This subroutine computes the derivatives of a normalized vector u, given
4381 C the derivatives computed without normalization conditions, ugrad. Returns
4382 C ungrad.
4383       implicit none
4384       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4385       double precision vec(3)
4386       double precision scalar
4387       integer i,j
4388 c      write (2,*) 'ugrad',ugrad
4389 c      write (2,*) 'u',u
4390       do i=1,3
4391         vec(i)=scalar(ugrad(1,i),u(1))
4392       enddo
4393 c      write (2,*) 'vec',vec
4394       do i=1,3
4395         do j=1,3
4396           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4397         enddo
4398       enddo
4399 c      write (2,*) 'ungrad',ungrad
4400       return
4401       end
4402 C-----------------------------------------------------------------------------
4403       subroutine escp(evdw2,evdw2_14)
4404 C
4405 C This subroutine calculates the excluded-volume interaction energy between
4406 C peptide-group centers and side chains and its gradient in virtual-bond and
4407 C side-chain vectors.
4408 C
4409       implicit real*8 (a-h,o-z)
4410       include 'DIMENSIONS'
4411       include 'sizesclu.dat'
4412       include 'COMMON.GEO'
4413       include 'COMMON.VAR'
4414       include 'COMMON.LOCAL'
4415       include 'COMMON.CHAIN'
4416       include 'COMMON.DERIV'
4417       include 'COMMON.INTERACT'
4418       include 'COMMON.FFIELD'
4419       include 'COMMON.IOUNITS'
4420       dimension ggg(3)
4421       evdw2=0.0D0
4422       evdw2_14=0.0d0
4423 cd    print '(a)','Enter ESCP'
4424 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
4425 c     &  ' scal14',scal14
4426       do i=iatscp_s,iatscp_e
4427         iteli=itel(i)
4428 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
4429 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
4430         if (iteli.eq.0) goto 1225
4431         xi=0.5D0*(c(1,i)+c(1,i+1))
4432         yi=0.5D0*(c(2,i)+c(2,i+1))
4433         zi=0.5D0*(c(3,i)+c(3,i+1))
4434
4435         do iint=1,nscp_gr(i)
4436
4437         do j=iscpstart(i,iint),iscpend(i,iint)
4438           itypj=itype(j)
4439 C Uncomment following three lines for SC-p interactions
4440 c         xj=c(1,nres+j)-xi
4441 c         yj=c(2,nres+j)-yi
4442 c         zj=c(3,nres+j)-zi
4443 C Uncomment following three lines for Ca-p interactions
4444           xj=c(1,j)-xi
4445           yj=c(2,j)-yi
4446           zj=c(3,j)-zi
4447           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4448           fac=rrij**expon2
4449           e1=fac*fac*aad(itypj,iteli)
4450           e2=fac*bad(itypj,iteli)
4451           if (iabs(j-i) .le. 2) then
4452             e1=scal14*e1
4453             e2=scal14*e2
4454             evdw2_14=evdw2_14+e1+e2
4455           endif
4456           evdwij=e1+e2
4457 c          write (iout,*) i,j,evdwij
4458           evdw2=evdw2+evdwij
4459           if (calc_grad) then
4460 C
4461 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4462 C
4463           fac=-(evdwij+e1)*rrij
4464           ggg(1)=xj*fac
4465           ggg(2)=yj*fac
4466           ggg(3)=zj*fac
4467           if (j.lt.i) then
4468 cd          write (iout,*) 'j<i'
4469 C Uncomment following three lines for SC-p interactions
4470 c           do k=1,3
4471 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4472 c           enddo
4473           else
4474 cd          write (iout,*) 'j>i'
4475             do k=1,3
4476               ggg(k)=-ggg(k)
4477 C Uncomment following line for SC-p interactions
4478 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4479             enddo
4480           endif
4481           do k=1,3
4482             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4483           enddo
4484           kstart=min0(i+1,j)
4485           kend=max0(i-1,j-1)
4486 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4487 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4488           do k=kstart,kend
4489             do l=1,3
4490               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4491             enddo
4492           enddo
4493           endif
4494         enddo
4495         enddo ! iint
4496  1225   continue
4497       enddo ! i
4498       do i=1,nct
4499         do j=1,3
4500           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4501           gradx_scp(j,i)=expon*gradx_scp(j,i)
4502         enddo
4503       enddo
4504 C******************************************************************************
4505 C
4506 C                              N O T E !!!
4507 C
4508 C To save time the factor EXPON has been extracted from ALL components
4509 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4510 C use!
4511 C
4512 C******************************************************************************
4513       return
4514       end
4515 C--------------------------------------------------------------------------
4516       subroutine edis(ehpb)
4517 C
4518 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4519 C
4520       implicit real*8 (a-h,o-z)
4521       include 'DIMENSIONS'
4522       include 'COMMON.SBRIDGE'
4523       include 'COMMON.CHAIN'
4524       include 'COMMON.DERIV'
4525       include 'COMMON.VAR'
4526       include 'COMMON.INTERACT'
4527       include 'COMMON.IOUNITS'
4528       dimension ggg(3)
4529       ehpb=0.0D0
4530 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4531 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4532       if (link_end.eq.0) return
4533       do i=link_start,link_end
4534 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4535 C CA-CA distance used in regularization of structure.
4536         ii=ihpb(i)
4537         jj=jhpb(i)
4538 C iii and jjj point to the residues for which the distance is assigned.
4539         if (ii.gt.nres) then
4540           iii=ii-nres
4541           jjj=jj-nres
4542         else
4543           iii=ii
4544           jjj=jj
4545         endif
4546 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4547 c     &    dhpb(i),dhpb1(i),forcon(i)
4548 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4549 C    distance and angle dependent SS bond potential.
4550         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4551           call ssbond_ene(iii,jjj,eij)
4552           ehpb=ehpb+2*eij
4553 cd          write (iout,*) "eij",eij
4554         else if (ii.gt.nres .and. jj.gt.nres) then
4555 c Restraints from contact prediction
4556           dd=dist(ii,jj)
4557           if (dhpb1(i).gt.0.0d0) then
4558             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4559             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4560 c            write (iout,*) "beta nmr",
4561 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4562           else
4563             dd=dist(ii,jj)
4564             rdis=dd-dhpb(i)
4565 C Get the force constant corresponding to this distance.
4566             waga=forcon(i)
4567 C Calculate the contribution to energy.
4568             ehpb=ehpb+waga*rdis*rdis
4569 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4570 C
4571 C Evaluate gradient.
4572 C
4573             fac=waga*rdis/dd
4574           endif
4575           do j=1,3
4576             ggg(j)=fac*(c(j,jj)-c(j,ii))
4577           enddo
4578           do j=1,3
4579             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4580             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4581           enddo
4582           do k=1,3
4583             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4584             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4585           enddo
4586         else
4587 C Calculate the distance between the two points and its difference from the
4588 C target distance.
4589           dd=dist(ii,jj)
4590           if (dhpb1(i).gt.0.0d0) then
4591             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4592             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4593 c            write (iout,*) "alph nmr",
4594 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4595           else
4596             rdis=dd-dhpb(i)
4597 C Get the force constant corresponding to this distance.
4598             waga=forcon(i)
4599 C Calculate the contribution to energy.
4600             ehpb=ehpb+waga*rdis*rdis
4601 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4602 C
4603 C Evaluate gradient.
4604 C
4605             fac=waga*rdis/dd
4606           endif
4607 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4608 cd   &   ' waga=',waga,' fac=',fac
4609             do j=1,3
4610               ggg(j)=fac*(c(j,jj)-c(j,ii))
4611             enddo
4612 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4613 C If this is a SC-SC distance, we need to calculate the contributions to the
4614 C Cartesian gradient in the SC vectors (ghpbx).
4615           if (iii.lt.ii) then
4616           do j=1,3
4617             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4618             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4619           enddo
4620           endif
4621           do k=1,3
4622             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4623             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4624           enddo
4625         endif
4626       enddo
4627       ehpb=0.5D0*ehpb
4628       return
4629       end
4630 C--------------------------------------------------------------------------
4631       subroutine ssbond_ene(i,j,eij)
4632 C
4633 C Calculate the distance and angle dependent SS-bond potential energy
4634 C using a free-energy function derived based on RHF/6-31G** ab initio
4635 C calculations of diethyl disulfide.
4636 C
4637 C A. Liwo and U. Kozlowska, 11/24/03
4638 C
4639       implicit real*8 (a-h,o-z)
4640       include 'DIMENSIONS'
4641       include 'sizesclu.dat'
4642       include 'COMMON.SBRIDGE'
4643       include 'COMMON.CHAIN'
4644       include 'COMMON.DERIV'
4645       include 'COMMON.LOCAL'
4646       include 'COMMON.INTERACT'
4647       include 'COMMON.VAR'
4648       include 'COMMON.IOUNITS'
4649       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4650       itypi=itype(i)
4651       xi=c(1,nres+i)
4652       yi=c(2,nres+i)
4653       zi=c(3,nres+i)
4654       dxi=dc_norm(1,nres+i)
4655       dyi=dc_norm(2,nres+i)
4656       dzi=dc_norm(3,nres+i)
4657       dsci_inv=dsc_inv(itypi)
4658       itypj=itype(j)
4659       dscj_inv=dsc_inv(itypj)
4660       xj=c(1,nres+j)-xi
4661       yj=c(2,nres+j)-yi
4662       zj=c(3,nres+j)-zi
4663       dxj=dc_norm(1,nres+j)
4664       dyj=dc_norm(2,nres+j)
4665       dzj=dc_norm(3,nres+j)
4666       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4667       rij=dsqrt(rrij)
4668       erij(1)=xj*rij
4669       erij(2)=yj*rij
4670       erij(3)=zj*rij
4671       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4672       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4673       om12=dxi*dxj+dyi*dyj+dzi*dzj
4674       do k=1,3
4675         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4676         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4677       enddo
4678       rij=1.0d0/rij
4679       deltad=rij-d0cm
4680       deltat1=1.0d0-om1
4681       deltat2=1.0d0+om2
4682       deltat12=om2-om1+2.0d0
4683       cosphi=om12-om1*om2
4684       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4685      &  +akct*deltad*deltat12
4686      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4687 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4688 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4689 c     &  " deltat12",deltat12," eij",eij
4690       ed=2*akcm*deltad+akct*deltat12
4691       pom1=akct*deltad
4692       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4693       eom1=-2*akth*deltat1-pom1-om2*pom2
4694       eom2= 2*akth*deltat2+pom1-om1*pom2
4695       eom12=pom2
4696       do k=1,3
4697         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4698       enddo
4699       do k=1,3
4700         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4701      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4702         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4703      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4704       enddo
4705 C
4706 C Calculate the components of the gradient in DC and X
4707 C
4708       do k=i,j-1
4709         do l=1,3
4710           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4711         enddo
4712       enddo
4713       return
4714       end
4715 C--------------------------------------------------------------------------
4716       subroutine ebond(estr)
4717 c
4718 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4719 c
4720       implicit real*8 (a-h,o-z)
4721       include 'DIMENSIONS'
4722       include 'COMMON.LOCAL'
4723       include 'COMMON.GEO'
4724       include 'COMMON.INTERACT'
4725       include 'COMMON.DERIV'
4726       include 'COMMON.VAR'
4727       include 'COMMON.CHAIN'
4728       include 'COMMON.IOUNITS'
4729       include 'COMMON.NAMES'
4730       include 'COMMON.FFIELD'
4731       include 'COMMON.CONTROL'
4732       double precision u(3),ud(3)
4733       estr=0.0d0
4734       do i=nnt+1,nct
4735         diff = vbld(i)-vbldp0
4736 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4737         estr=estr+diff*diff
4738         do j=1,3
4739           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4740         enddo
4741       enddo
4742       estr=0.5d0*AKP*estr
4743 c
4744 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4745 c
4746       do i=nnt,nct
4747         iti=itype(i)
4748         if (iti.ne.10) then
4749           nbi=nbondterm(iti)
4750           if (nbi.eq.1) then
4751             diff=vbld(i+nres)-vbldsc0(1,iti)
4752 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4753 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4754             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4755             do j=1,3
4756               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4757             enddo
4758           else
4759             do j=1,nbi
4760               diff=vbld(i+nres)-vbldsc0(j,iti)
4761               ud(j)=aksc(j,iti)*diff
4762               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4763             enddo
4764             uprod=u(1)
4765             do j=2,nbi
4766               uprod=uprod*u(j)
4767             enddo
4768             usum=0.0d0
4769             usumsqder=0.0d0
4770             do j=1,nbi
4771               uprod1=1.0d0
4772               uprod2=1.0d0
4773               do k=1,nbi
4774                 if (k.ne.j) then
4775                   uprod1=uprod1*u(k)
4776                   uprod2=uprod2*u(k)*u(k)
4777                 endif
4778               enddo
4779               usum=usum+uprod1
4780               usumsqder=usumsqder+ud(j)*uprod2
4781             enddo
4782 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4783 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4784             estr=estr+uprod/usum
4785             do j=1,3
4786              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4787             enddo
4788           endif
4789         endif
4790       enddo
4791       return
4792       end
4793 #ifdef CRYST_THETA
4794 C--------------------------------------------------------------------------
4795       subroutine ebend(etheta)
4796 C
4797 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4798 C angles gamma and its derivatives in consecutive thetas and gammas.
4799 C
4800       implicit real*8 (a-h,o-z)
4801       include 'DIMENSIONS'
4802       include 'sizesclu.dat'
4803       include 'COMMON.LOCAL'
4804       include 'COMMON.GEO'
4805       include 'COMMON.INTERACT'
4806       include 'COMMON.DERIV'
4807       include 'COMMON.VAR'
4808       include 'COMMON.CHAIN'
4809       include 'COMMON.IOUNITS'
4810       include 'COMMON.NAMES'
4811       include 'COMMON.FFIELD'
4812       common /calcthet/ term1,term2,termm,diffak,ratak,
4813      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4814      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4815       double precision y(2),z(2)
4816       delta=0.02d0*pi
4817       time11=dexp(-2*time)
4818       time12=1.0d0
4819       etheta=0.0D0
4820 c      write (iout,*) "nres",nres
4821 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4822 c      write (iout,*) ithet_start,ithet_end
4823       do i=ithet_start,ithet_end
4824 C Zero the energy function and its derivative at 0 or pi.
4825         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4826         it=itype(i-1)
4827 c        if (i.gt.ithet_start .and.
4828 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
4829 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
4830 c          phii=phi(i)
4831 c          y(1)=dcos(phii)
4832 c          y(2)=dsin(phii)
4833 c        else
4834 c          y(1)=0.0D0
4835 c          y(2)=0.0D0
4836 c        endif
4837 c        if (i.lt.nres .and. itel(i).ne.0) then
4838 c          phii1=phi(i+1)
4839 c          z(1)=dcos(phii1)
4840 c          z(2)=dsin(phii1)
4841 c        else
4842 c          z(1)=0.0D0
4843 c          z(2)=0.0D0
4844 c        endif
4845         if (i.gt.3) then
4846 #ifdef OSF
4847           phii=phi(i)
4848           icrc=0
4849           call proc_proc(phii,icrc)
4850           if (icrc.eq.1) phii=150.0
4851 #else
4852           phii=phi(i)
4853 #endif
4854           y(1)=dcos(phii)
4855           y(2)=dsin(phii)
4856         else
4857           y(1)=0.0D0
4858           y(2)=0.0D0
4859         endif
4860         if (i.lt.nres) then
4861 #ifdef OSF
4862           phii1=phi(i+1)
4863           icrc=0
4864           call proc_proc(phii1,icrc)
4865           if (icrc.eq.1) phii1=150.0
4866           phii1=pinorm(phii1)
4867           z(1)=cos(phii1)
4868 #else
4869           phii1=phi(i+1)
4870           z(1)=dcos(phii1)
4871 #endif
4872           z(2)=dsin(phii1)
4873         else
4874           z(1)=0.0D0
4875           z(2)=0.0D0
4876         endif
4877 C Calculate the "mean" value of theta from the part of the distribution
4878 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4879 C In following comments this theta will be referred to as t_c.
4880         thet_pred_mean=0.0d0
4881         do k=1,2
4882           athetk=athet(k,it)
4883           bthetk=bthet(k,it)
4884           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4885         enddo
4886 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4887         dthett=thet_pred_mean*ssd
4888         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4889 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4890 C Derivatives of the "mean" values in gamma1 and gamma2.
4891         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4892         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4893         if (theta(i).gt.pi-delta) then
4894           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4895      &         E_tc0)
4896           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4897           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4898           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4899      &        E_theta)
4900           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4901      &        E_tc)
4902         else if (theta(i).lt.delta) then
4903           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4904           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4905           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4906      &        E_theta)
4907           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4908           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4909      &        E_tc)
4910         else
4911           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4912      &        E_theta,E_tc)
4913         endif
4914         etheta=etheta+ethetai
4915 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4916 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4917         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4918         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4919         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4920  1215   continue
4921       enddo
4922 C Ufff.... We've done all this!!!
4923       return
4924       end
4925 C---------------------------------------------------------------------------
4926       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4927      &     E_tc)
4928       implicit real*8 (a-h,o-z)
4929       include 'DIMENSIONS'
4930       include 'COMMON.LOCAL'
4931       include 'COMMON.IOUNITS'
4932       common /calcthet/ term1,term2,termm,diffak,ratak,
4933      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4934      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4935 C Calculate the contributions to both Gaussian lobes.
4936 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4937 C The "polynomial part" of the "standard deviation" of this part of
4938 C the distribution.
4939         sig=polthet(3,it)
4940         do j=2,0,-1
4941           sig=sig*thet_pred_mean+polthet(j,it)
4942         enddo
4943 C Derivative of the "interior part" of the "standard deviation of the"
4944 C gamma-dependent Gaussian lobe in t_c.
4945         sigtc=3*polthet(3,it)
4946         do j=2,1,-1
4947           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4948         enddo
4949         sigtc=sig*sigtc
4950 C Set the parameters of both Gaussian lobes of the distribution.
4951 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4952         fac=sig*sig+sigc0(it)
4953         sigcsq=fac+fac
4954         sigc=1.0D0/sigcsq
4955 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4956         sigsqtc=-4.0D0*sigcsq*sigtc
4957 c       print *,i,sig,sigtc,sigsqtc
4958 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4959         sigtc=-sigtc/(fac*fac)
4960 C Following variable is sigma(t_c)**(-2)
4961         sigcsq=sigcsq*sigcsq
4962         sig0i=sig0(it)
4963         sig0inv=1.0D0/sig0i**2
4964         delthec=thetai-thet_pred_mean
4965         delthe0=thetai-theta0i
4966         term1=-0.5D0*sigcsq*delthec*delthec
4967         term2=-0.5D0*sig0inv*delthe0*delthe0
4968 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4969 C NaNs in taking the logarithm. We extract the largest exponent which is added
4970 C to the energy (this being the log of the distribution) at the end of energy
4971 C term evaluation for this virtual-bond angle.
4972         if (term1.gt.term2) then
4973           termm=term1
4974           term2=dexp(term2-termm)
4975           term1=1.0d0
4976         else
4977           termm=term2
4978           term1=dexp(term1-termm)
4979           term2=1.0d0
4980         endif
4981 C The ratio between the gamma-independent and gamma-dependent lobes of
4982 C the distribution is a Gaussian function of thet_pred_mean too.
4983         diffak=gthet(2,it)-thet_pred_mean
4984         ratak=diffak/gthet(3,it)**2
4985         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4986 C Let's differentiate it in thet_pred_mean NOW.
4987         aktc=ak*ratak
4988 C Now put together the distribution terms to make complete distribution.
4989         termexp=term1+ak*term2
4990         termpre=sigc+ak*sig0i
4991 C Contribution of the bending energy from this theta is just the -log of
4992 C the sum of the contributions from the two lobes and the pre-exponential
4993 C factor. Simple enough, isn't it?
4994         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4995 C NOW the derivatives!!!
4996 C 6/6/97 Take into account the deformation.
4997         E_theta=(delthec*sigcsq*term1
4998      &       +ak*delthe0*sig0inv*term2)/termexp
4999         E_tc=((sigtc+aktc*sig0i)/termpre
5000      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
5001      &       aktc*term2)/termexp)
5002       return
5003       end
5004 c-----------------------------------------------------------------------------
5005       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
5006       implicit real*8 (a-h,o-z)
5007       include 'DIMENSIONS'
5008       include 'COMMON.LOCAL'
5009       include 'COMMON.IOUNITS'
5010       common /calcthet/ term1,term2,termm,diffak,ratak,
5011      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5012      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5013       delthec=thetai-thet_pred_mean
5014       delthe0=thetai-theta0i
5015 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
5016       t3 = thetai-thet_pred_mean
5017       t6 = t3**2
5018       t9 = term1
5019       t12 = t3*sigcsq
5020       t14 = t12+t6*sigsqtc
5021       t16 = 1.0d0
5022       t21 = thetai-theta0i
5023       t23 = t21**2
5024       t26 = term2
5025       t27 = t21*t26
5026       t32 = termexp
5027       t40 = t32**2
5028       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
5029      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
5030      & *(-t12*t9-ak*sig0inv*t27)
5031       return
5032       end
5033 #else
5034 C--------------------------------------------------------------------------
5035       subroutine ebend(etheta)
5036 C
5037 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5038 C angles gamma and its derivatives in consecutive thetas and gammas.
5039 C ab initio-derived potentials from
5040 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5041 C
5042       implicit real*8 (a-h,o-z)
5043       include 'DIMENSIONS'
5044       include 'COMMON.LOCAL'
5045       include 'COMMON.GEO'
5046       include 'COMMON.INTERACT'
5047       include 'COMMON.DERIV'
5048       include 'COMMON.VAR'
5049       include 'COMMON.CHAIN'
5050       include 'COMMON.IOUNITS'
5051       include 'COMMON.NAMES'
5052       include 'COMMON.FFIELD'
5053       include 'COMMON.CONTROL'
5054       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
5055      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
5056      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
5057      & sinph1ph2(maxdouble,maxdouble)
5058       logical lprn /.false./, lprn1 /.false./
5059       etheta=0.0D0
5060 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
5061       do i=ithet_start,ithet_end
5062         dethetai=0.0d0
5063         dephii=0.0d0
5064         dephii1=0.0d0
5065         theti2=0.5d0*theta(i)
5066         ityp2=ithetyp(itype(i-1))
5067         do k=1,nntheterm
5068           coskt(k)=dcos(k*theti2)
5069           sinkt(k)=dsin(k*theti2)
5070         enddo
5071         if (i.gt.3) then
5072 #ifdef OSF
5073           phii=phi(i)
5074           if (phii.ne.phii) phii=150.0
5075 #else
5076           phii=phi(i)
5077 #endif
5078           ityp1=ithetyp(itype(i-2))
5079           do k=1,nsingle
5080             cosph1(k)=dcos(k*phii)
5081             sinph1(k)=dsin(k*phii)
5082           enddo
5083         else
5084           phii=0.0d0
5085           ityp1=nthetyp+1
5086           do k=1,nsingle
5087             cosph1(k)=0.0d0
5088             sinph1(k)=0.0d0
5089           enddo
5090         endif
5091         if (i.lt.nres) then
5092 #ifdef OSF
5093           phii1=phi(i+1)
5094           if (phii1.ne.phii1) phii1=150.0
5095           phii1=pinorm(phii1)
5096 #else
5097           phii1=phi(i+1)
5098 #endif
5099           ityp3=ithetyp(itype(i))
5100           do k=1,nsingle
5101             cosph2(k)=dcos(k*phii1)
5102             sinph2(k)=dsin(k*phii1)
5103           enddo
5104         else
5105           phii1=0.0d0
5106           ityp3=nthetyp+1
5107           do k=1,nsingle
5108             cosph2(k)=0.0d0
5109             sinph2(k)=0.0d0
5110           enddo
5111         endif
5112 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5113 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5114 c        call flush(iout)
5115         ethetai=aa0thet(ityp1,ityp2,ityp3)
5116         do k=1,ndouble
5117           do l=1,k-1
5118             ccl=cosph1(l)*cosph2(k-l)
5119             ssl=sinph1(l)*sinph2(k-l)
5120             scl=sinph1(l)*cosph2(k-l)
5121             csl=cosph1(l)*sinph2(k-l)
5122             cosph1ph2(l,k)=ccl-ssl
5123             cosph1ph2(k,l)=ccl+ssl
5124             sinph1ph2(l,k)=scl+csl
5125             sinph1ph2(k,l)=scl-csl
5126           enddo
5127         enddo
5128         if (lprn) then
5129         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5130      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5131         write (iout,*) "coskt and sinkt"
5132         do k=1,nntheterm
5133           write (iout,*) k,coskt(k),sinkt(k)
5134         enddo
5135         endif
5136         do k=1,ntheterm
5137           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
5138           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
5139      &      *coskt(k)
5140           if (lprn)
5141      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
5142      &     " ethetai",ethetai
5143         enddo
5144         if (lprn) then
5145         write (iout,*) "cosph and sinph"
5146         do k=1,nsingle
5147           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5148         enddo
5149         write (iout,*) "cosph1ph2 and sinph2ph2"
5150         do k=2,ndouble
5151           do l=1,k-1
5152             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5153      &         sinph1ph2(l,k),sinph1ph2(k,l)
5154           enddo
5155         enddo
5156         write(iout,*) "ethetai",ethetai
5157         endif
5158         do m=1,ntheterm2
5159           do k=1,nsingle
5160             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
5161      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
5162      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
5163      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
5164             ethetai=ethetai+sinkt(m)*aux
5165             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5166             dephii=dephii+k*sinkt(m)*(
5167      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
5168      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
5169             dephii1=dephii1+k*sinkt(m)*(
5170      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
5171      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
5172             if (lprn)
5173      &      write (iout,*) "m",m," k",k," bbthet",
5174      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
5175      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
5176      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
5177      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5178           enddo
5179         enddo
5180         if (lprn)
5181      &  write(iout,*) "ethetai",ethetai
5182         do m=1,ntheterm3
5183           do k=2,ndouble
5184             do l=1,k-1
5185               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5186      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
5187      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5188      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
5189               ethetai=ethetai+sinkt(m)*aux
5190               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5191               dephii=dephii+l*sinkt(m)*(
5192      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
5193      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5194      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5195      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5196               dephii1=dephii1+(k-l)*sinkt(m)*(
5197      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5198      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5199      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5200      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5201               if (lprn) then
5202               write (iout,*) "m",m," k",k," l",l," ffthet",
5203      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5204      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5205      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5206      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5207               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5208      &            cosph1ph2(k,l)*sinkt(m),
5209      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5210               endif
5211             enddo
5212           enddo
5213         enddo
5214 10      continue
5215         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5216      &   i,theta(i)*rad2deg,phii*rad2deg,
5217      &   phii1*rad2deg,ethetai
5218         etheta=etheta+ethetai
5219         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5220         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5221         gloc(nphi+i-2,icg)=wang*dethetai
5222       enddo
5223       return
5224       end
5225 #endif
5226 #ifdef CRYST_SC
5227 c-----------------------------------------------------------------------------
5228       subroutine esc(escloc)
5229 C Calculate the local energy of a side chain and its derivatives in the
5230 C corresponding virtual-bond valence angles THETA and the spherical angles
5231 C ALPHA and OMEGA.
5232       implicit real*8 (a-h,o-z)
5233       include 'DIMENSIONS'
5234       include 'sizesclu.dat'
5235       include 'COMMON.GEO'
5236       include 'COMMON.LOCAL'
5237       include 'COMMON.VAR'
5238       include 'COMMON.INTERACT'
5239       include 'COMMON.DERIV'
5240       include 'COMMON.CHAIN'
5241       include 'COMMON.IOUNITS'
5242       include 'COMMON.NAMES'
5243       include 'COMMON.FFIELD'
5244       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5245      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5246       common /sccalc/ time11,time12,time112,theti,it,nlobit
5247       delta=0.02d0*pi
5248       escloc=0.0D0
5249 c     write (iout,'(a)') 'ESC'
5250       do i=loc_start,loc_end
5251         it=itype(i)
5252         if (it.eq.10) goto 1
5253         nlobit=nlob(it)
5254 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5255 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5256         theti=theta(i+1)-pipol
5257         x(1)=dtan(theti)
5258         x(2)=alph(i)
5259         x(3)=omeg(i)
5260 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5261
5262         if (x(2).gt.pi-delta) then
5263           xtemp(1)=x(1)
5264           xtemp(2)=pi-delta
5265           xtemp(3)=x(3)
5266           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5267           xtemp(2)=pi
5268           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5269           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5270      &        escloci,dersc(2))
5271           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5272      &        ddersc0(1),dersc(1))
5273           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5274      &        ddersc0(3),dersc(3))
5275           xtemp(2)=pi-delta
5276           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5277           xtemp(2)=pi
5278           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5279           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5280      &            dersc0(2),esclocbi,dersc02)
5281           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5282      &            dersc12,dersc01)
5283           call splinthet(x(2),0.5d0*delta,ss,ssd)
5284           dersc0(1)=dersc01
5285           dersc0(2)=dersc02
5286           dersc0(3)=0.0d0
5287           do k=1,3
5288             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5289           enddo
5290           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5291 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5292 c    &             esclocbi,ss,ssd
5293           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5294 c         escloci=esclocbi
5295 c         write (iout,*) escloci
5296         else if (x(2).lt.delta) then
5297           xtemp(1)=x(1)
5298           xtemp(2)=delta
5299           xtemp(3)=x(3)
5300           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5301           xtemp(2)=0.0d0
5302           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5303           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5304      &        escloci,dersc(2))
5305           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5306      &        ddersc0(1),dersc(1))
5307           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5308      &        ddersc0(3),dersc(3))
5309           xtemp(2)=delta
5310           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5311           xtemp(2)=0.0d0
5312           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5313           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5314      &            dersc0(2),esclocbi,dersc02)
5315           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5316      &            dersc12,dersc01)
5317           dersc0(1)=dersc01
5318           dersc0(2)=dersc02
5319           dersc0(3)=0.0d0
5320           call splinthet(x(2),0.5d0*delta,ss,ssd)
5321           do k=1,3
5322             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5323           enddo
5324           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5325 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5326 c    &             esclocbi,ss,ssd
5327           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5328 c         write (iout,*) escloci
5329         else
5330           call enesc(x,escloci,dersc,ddummy,.false.)
5331         endif
5332
5333         escloc=escloc+escloci
5334 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5335
5336         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5337      &   wscloc*dersc(1)
5338         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5339         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5340     1   continue
5341       enddo
5342       return
5343       end
5344 C---------------------------------------------------------------------------
5345       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5346       implicit real*8 (a-h,o-z)
5347       include 'DIMENSIONS'
5348       include 'COMMON.GEO'
5349       include 'COMMON.LOCAL'
5350       include 'COMMON.IOUNITS'
5351       common /sccalc/ time11,time12,time112,theti,it,nlobit
5352       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5353       double precision contr(maxlob,-1:1)
5354       logical mixed
5355 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5356         escloc_i=0.0D0
5357         do j=1,3
5358           dersc(j)=0.0D0
5359           if (mixed) ddersc(j)=0.0d0
5360         enddo
5361         x3=x(3)
5362
5363 C Because of periodicity of the dependence of the SC energy in omega we have
5364 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5365 C To avoid underflows, first compute & store the exponents.
5366
5367         do iii=-1,1
5368
5369           x(3)=x3+iii*dwapi
5370
5371           do j=1,nlobit
5372             do k=1,3
5373               z(k)=x(k)-censc(k,j,it)
5374             enddo
5375             do k=1,3
5376               Axk=0.0D0
5377               do l=1,3
5378                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5379               enddo
5380               Ax(k,j,iii)=Axk
5381             enddo
5382             expfac=0.0D0
5383             do k=1,3
5384               expfac=expfac+Ax(k,j,iii)*z(k)
5385             enddo
5386             contr(j,iii)=expfac
5387           enddo ! j
5388
5389         enddo ! iii
5390
5391         x(3)=x3
5392 C As in the case of ebend, we want to avoid underflows in exponentiation and
5393 C subsequent NaNs and INFs in energy calculation.
5394 C Find the largest exponent
5395         emin=contr(1,-1)
5396         do iii=-1,1
5397           do j=1,nlobit
5398             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5399           enddo
5400         enddo
5401         emin=0.5D0*emin
5402 cd      print *,'it=',it,' emin=',emin
5403
5404 C Compute the contribution to SC energy and derivatives
5405         do iii=-1,1
5406
5407           do j=1,nlobit
5408             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5409 cd          print *,'j=',j,' expfac=',expfac
5410             escloc_i=escloc_i+expfac
5411             do k=1,3
5412               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5413             enddo
5414             if (mixed) then
5415               do k=1,3,2
5416                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5417      &            +gaussc(k,2,j,it))*expfac
5418               enddo
5419             endif
5420           enddo
5421
5422         enddo ! iii
5423
5424         dersc(1)=dersc(1)/cos(theti)**2
5425         ddersc(1)=ddersc(1)/cos(theti)**2
5426         ddersc(3)=ddersc(3)
5427
5428         escloci=-(dlog(escloc_i)-emin)
5429         do j=1,3
5430           dersc(j)=dersc(j)/escloc_i
5431         enddo
5432         if (mixed) then
5433           do j=1,3,2
5434             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5435           enddo
5436         endif
5437       return
5438       end
5439 C------------------------------------------------------------------------------
5440       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5441       implicit real*8 (a-h,o-z)
5442       include 'DIMENSIONS'
5443       include 'COMMON.GEO'
5444       include 'COMMON.LOCAL'
5445       include 'COMMON.IOUNITS'
5446       common /sccalc/ time11,time12,time112,theti,it,nlobit
5447       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5448       double precision contr(maxlob)
5449       logical mixed
5450
5451       escloc_i=0.0D0
5452
5453       do j=1,3
5454         dersc(j)=0.0D0
5455       enddo
5456
5457       do j=1,nlobit
5458         do k=1,2
5459           z(k)=x(k)-censc(k,j,it)
5460         enddo
5461         z(3)=dwapi
5462         do k=1,3
5463           Axk=0.0D0
5464           do l=1,3
5465             Axk=Axk+gaussc(l,k,j,it)*z(l)
5466           enddo
5467           Ax(k,j)=Axk
5468         enddo
5469         expfac=0.0D0
5470         do k=1,3
5471           expfac=expfac+Ax(k,j)*z(k)
5472         enddo
5473         contr(j)=expfac
5474       enddo ! j
5475
5476 C As in the case of ebend, we want to avoid underflows in exponentiation and
5477 C subsequent NaNs and INFs in energy calculation.
5478 C Find the largest exponent
5479       emin=contr(1)
5480       do j=1,nlobit
5481         if (emin.gt.contr(j)) emin=contr(j)
5482       enddo
5483       emin=0.5D0*emin
5484
5485 C Compute the contribution to SC energy and derivatives
5486
5487       dersc12=0.0d0
5488       do j=1,nlobit
5489         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5490         escloc_i=escloc_i+expfac
5491         do k=1,2
5492           dersc(k)=dersc(k)+Ax(k,j)*expfac
5493         enddo
5494         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5495      &            +gaussc(1,2,j,it))*expfac
5496         dersc(3)=0.0d0
5497       enddo
5498
5499       dersc(1)=dersc(1)/cos(theti)**2
5500       dersc12=dersc12/cos(theti)**2
5501       escloci=-(dlog(escloc_i)-emin)
5502       do j=1,2
5503         dersc(j)=dersc(j)/escloc_i
5504       enddo
5505       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5506       return
5507       end
5508 #else
5509 c----------------------------------------------------------------------------------
5510       subroutine esc(escloc)
5511 C Calculate the local energy of a side chain and its derivatives in the
5512 C corresponding virtual-bond valence angles THETA and the spherical angles
5513 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5514 C added by Urszula Kozlowska. 07/11/2007
5515 C
5516       implicit real*8 (a-h,o-z)
5517       include 'DIMENSIONS'
5518       include 'COMMON.GEO'
5519       include 'COMMON.LOCAL'
5520       include 'COMMON.VAR'
5521       include 'COMMON.SCROT'
5522       include 'COMMON.INTERACT'
5523       include 'COMMON.DERIV'
5524       include 'COMMON.CHAIN'
5525       include 'COMMON.IOUNITS'
5526       include 'COMMON.NAMES'
5527       include 'COMMON.FFIELD'
5528       include 'COMMON.CONTROL'
5529       include 'COMMON.VECTORS'
5530       double precision x_prime(3),y_prime(3),z_prime(3)
5531      &    , sumene,dsc_i,dp2_i,x(65),
5532      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5533      &    de_dxx,de_dyy,de_dzz,de_dt
5534       double precision s1_t,s1_6_t,s2_t,s2_6_t
5535       double precision
5536      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5537      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5538      & dt_dCi(3),dt_dCi1(3)
5539       common /sccalc/ time11,time12,time112,theti,it,nlobit
5540       delta=0.02d0*pi
5541       escloc=0.0D0
5542       do i=loc_start,loc_end
5543         costtab(i+1) =dcos(theta(i+1))
5544         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5545         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5546         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5547         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5548         cosfac=dsqrt(cosfac2)
5549         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5550         sinfac=dsqrt(sinfac2)
5551         it=itype(i)
5552         if (it.eq.10) goto 1
5553 c
5554 C  Compute the axes of tghe local cartesian coordinates system; store in
5555 c   x_prime, y_prime and z_prime
5556 c
5557         do j=1,3
5558           x_prime(j) = 0.00
5559           y_prime(j) = 0.00
5560           z_prime(j) = 0.00
5561         enddo
5562 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5563 C     &   dc_norm(3,i+nres)
5564         do j = 1,3
5565           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5566           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5567         enddo
5568         do j = 1,3
5569           z_prime(j) = -uz(j,i-1)
5570         enddo
5571 c       write (2,*) "i",i
5572 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5573 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5574 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5575 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5576 c      & " xy",scalar(x_prime(1),y_prime(1)),
5577 c      & " xz",scalar(x_prime(1),z_prime(1)),
5578 c      & " yy",scalar(y_prime(1),y_prime(1)),
5579 c      & " yz",scalar(y_prime(1),z_prime(1)),
5580 c      & " zz",scalar(z_prime(1),z_prime(1))
5581 c
5582 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5583 C to local coordinate system. Store in xx, yy, zz.
5584 c
5585         xx=0.0d0
5586         yy=0.0d0
5587         zz=0.0d0
5588         do j = 1,3
5589           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5590           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5591           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5592         enddo
5593
5594         xxtab(i)=xx
5595         yytab(i)=yy
5596         zztab(i)=zz
5597 C
5598 C Compute the energy of the ith side cbain
5599 C
5600 c        write (2,*) "xx",xx," yy",yy," zz",zz
5601         it=itype(i)
5602         do j = 1,65
5603           x(j) = sc_parmin(j,it)
5604         enddo
5605 #ifdef CHECK_COORD
5606 Cc diagnostics - remove later
5607         xx1 = dcos(alph(2))
5608         yy1 = dsin(alph(2))*dcos(omeg(2))
5609         zz1 = -dsin(alph(2))*dsin(omeg(2))
5610         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5611      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5612      &    xx1,yy1,zz1
5613 C,"  --- ", xx_w,yy_w,zz_w
5614 c end diagnostics
5615 #endif
5616         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5617      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5618      &   + x(10)*yy*zz
5619         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5620      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5621      & + x(20)*yy*zz
5622         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5623      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5624      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5625      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5626      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5627      &  +x(40)*xx*yy*zz
5628         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5629      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5630      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5631      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5632      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5633      &  +x(60)*xx*yy*zz
5634         dsc_i   = 0.743d0+x(61)
5635         dp2_i   = 1.9d0+x(62)
5636         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5637      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5638         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5639      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5640         s1=(1+x(63))/(0.1d0 + dscp1)
5641         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5642         s2=(1+x(65))/(0.1d0 + dscp2)
5643         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5644         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5645      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5646 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5647 c     &   sumene4,
5648 c     &   dscp1,dscp2,sumene
5649 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5650         escloc = escloc + sumene
5651 c        write (2,*) "escloc",escloc
5652         if (.not. calc_grad) goto 1
5653 #ifdef DEBUG
5654 C
5655 C This section to check the numerical derivatives of the energy of ith side
5656 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5657 C #define DEBUG in the code to turn it on.
5658 C
5659         write (2,*) "sumene               =",sumene
5660         aincr=1.0d-7
5661         xxsave=xx
5662         xx=xx+aincr
5663         write (2,*) xx,yy,zz
5664         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5665         de_dxx_num=(sumenep-sumene)/aincr
5666         xx=xxsave
5667         write (2,*) "xx+ sumene from enesc=",sumenep
5668         yysave=yy
5669         yy=yy+aincr
5670         write (2,*) xx,yy,zz
5671         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5672         de_dyy_num=(sumenep-sumene)/aincr
5673         yy=yysave
5674         write (2,*) "yy+ sumene from enesc=",sumenep
5675         zzsave=zz
5676         zz=zz+aincr
5677         write (2,*) xx,yy,zz
5678         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5679         de_dzz_num=(sumenep-sumene)/aincr
5680         zz=zzsave
5681         write (2,*) "zz+ sumene from enesc=",sumenep
5682         costsave=cost2tab(i+1)
5683         sintsave=sint2tab(i+1)
5684         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5685         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5686         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5687         de_dt_num=(sumenep-sumene)/aincr
5688         write (2,*) " t+ sumene from enesc=",sumenep
5689         cost2tab(i+1)=costsave
5690         sint2tab(i+1)=sintsave
5691 C End of diagnostics section.
5692 #endif
5693 C
5694 C Compute the gradient of esc
5695 C
5696         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5697         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5698         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5699         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5700         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5701         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5702         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5703         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5704         pom1=(sumene3*sint2tab(i+1)+sumene1)
5705      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5706         pom2=(sumene4*cost2tab(i+1)+sumene2)
5707      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5708         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5709         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5710      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5711      &  +x(40)*yy*zz
5712         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5713         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5714      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5715      &  +x(60)*yy*zz
5716         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5717      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5718      &        +(pom1+pom2)*pom_dx
5719 #ifdef DEBUG
5720         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5721 #endif
5722 C
5723         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5724         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5725      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5726      &  +x(40)*xx*zz
5727         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5728         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5729      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5730      &  +x(59)*zz**2 +x(60)*xx*zz
5731         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5732      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5733      &        +(pom1-pom2)*pom_dy
5734 #ifdef DEBUG
5735         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5736 #endif
5737 C
5738         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5739      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5740      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5741      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5742      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5743      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5744      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5745      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5746 #ifdef DEBUG
5747         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5748 #endif
5749 C
5750         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5751      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5752      &  +pom1*pom_dt1+pom2*pom_dt2
5753 #ifdef DEBUG
5754         write(2,*), "de_dt = ", de_dt,de_dt_num
5755 #endif
5756 c
5757 C
5758        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5759        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5760        cosfac2xx=cosfac2*xx
5761        sinfac2yy=sinfac2*yy
5762        do k = 1,3
5763          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5764      &      vbld_inv(i+1)
5765          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5766      &      vbld_inv(i)
5767          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5768          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5769 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5770 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5771 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5772 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5773          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5774          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5775          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5776          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5777          dZZ_Ci1(k)=0.0d0
5778          dZZ_Ci(k)=0.0d0
5779          do j=1,3
5780            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5781            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5782          enddo
5783
5784          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5785          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5786          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5787 c
5788          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5789          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5790        enddo
5791
5792        do k=1,3
5793          dXX_Ctab(k,i)=dXX_Ci(k)
5794          dXX_C1tab(k,i)=dXX_Ci1(k)
5795          dYY_Ctab(k,i)=dYY_Ci(k)
5796          dYY_C1tab(k,i)=dYY_Ci1(k)
5797          dZZ_Ctab(k,i)=dZZ_Ci(k)
5798          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5799          dXX_XYZtab(k,i)=dXX_XYZ(k)
5800          dYY_XYZtab(k,i)=dYY_XYZ(k)
5801          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5802        enddo
5803
5804        do k = 1,3
5805 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5806 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5807 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5808 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5809 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5810 c     &    dt_dci(k)
5811 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5812 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5813          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5814      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5815          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5816      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5817          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5818      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5819        enddo
5820 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5821 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5822
5823 C to check gradient call subroutine check_grad
5824
5825     1 continue
5826       enddo
5827       return
5828       end
5829 #endif
5830 c------------------------------------------------------------------------------
5831       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5832 C
5833 C This procedure calculates two-body contact function g(rij) and its derivative:
5834 C
5835 C           eps0ij                                     !       x < -1
5836 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5837 C            0                                         !       x > 1
5838 C
5839 C where x=(rij-r0ij)/delta
5840 C
5841 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5842 C
5843       implicit none
5844       double precision rij,r0ij,eps0ij,fcont,fprimcont
5845       double precision x,x2,x4,delta
5846 c     delta=0.02D0*r0ij
5847 c      delta=0.2D0*r0ij
5848       x=(rij-r0ij)/delta
5849       if (x.lt.-1.0D0) then
5850         fcont=eps0ij
5851         fprimcont=0.0D0
5852       else if (x.le.1.0D0) then
5853         x2=x*x
5854         x4=x2*x2
5855         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5856         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5857       else
5858         fcont=0.0D0
5859         fprimcont=0.0D0
5860       endif
5861       return
5862       end
5863 c------------------------------------------------------------------------------
5864       subroutine splinthet(theti,delta,ss,ssder)
5865       implicit real*8 (a-h,o-z)
5866       include 'DIMENSIONS'
5867       include 'sizesclu.dat'
5868       include 'COMMON.VAR'
5869       include 'COMMON.GEO'
5870       thetup=pi-delta
5871       thetlow=delta
5872       if (theti.gt.pipol) then
5873         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5874       else
5875         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5876         ssder=-ssder
5877       endif
5878       return
5879       end
5880 c------------------------------------------------------------------------------
5881       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5882       implicit none
5883       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5884       double precision ksi,ksi2,ksi3,a1,a2,a3
5885       a1=fprim0*delta/(f1-f0)
5886       a2=3.0d0-2.0d0*a1
5887       a3=a1-2.0d0
5888       ksi=(x-x0)/delta
5889       ksi2=ksi*ksi
5890       ksi3=ksi2*ksi
5891       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5892       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5893       return
5894       end
5895 c------------------------------------------------------------------------------
5896       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5897       implicit none
5898       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5899       double precision ksi,ksi2,ksi3,a1,a2,a3
5900       ksi=(x-x0)/delta
5901       ksi2=ksi*ksi
5902       ksi3=ksi2*ksi
5903       a1=fprim0x*delta
5904       a2=3*(f1x-f0x)-2*fprim0x*delta
5905       a3=fprim0x*delta-2*(f1x-f0x)
5906       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5907       return
5908       end
5909 C-----------------------------------------------------------------------------
5910 #ifdef CRYST_TOR
5911 C-----------------------------------------------------------------------------
5912       subroutine etor(etors,edihcnstr,fact)
5913       implicit real*8 (a-h,o-z)
5914       include 'DIMENSIONS'
5915       include 'sizesclu.dat'
5916       include 'COMMON.VAR'
5917       include 'COMMON.GEO'
5918       include 'COMMON.LOCAL'
5919       include 'COMMON.TORSION'
5920       include 'COMMON.INTERACT'
5921       include 'COMMON.DERIV'
5922       include 'COMMON.CHAIN'
5923       include 'COMMON.NAMES'
5924       include 'COMMON.IOUNITS'
5925       include 'COMMON.FFIELD'
5926       include 'COMMON.TORCNSTR'
5927       logical lprn
5928 C Set lprn=.true. for debugging
5929       lprn=.false.
5930 c      lprn=.true.
5931       etors=0.0D0
5932       do i=iphi_start,iphi_end
5933         itori=itortyp(itype(i-2))
5934         itori1=itortyp(itype(i-1))
5935         phii=phi(i)
5936         gloci=0.0D0
5937 C Proline-Proline pair is a special case...
5938         if (itori.eq.3 .and. itori1.eq.3) then
5939           if (phii.gt.-dwapi3) then
5940             cosphi=dcos(3*phii)
5941             fac=1.0D0/(1.0D0-cosphi)
5942             etorsi=v1(1,3,3)*fac
5943             etorsi=etorsi+etorsi
5944             etors=etors+etorsi-v1(1,3,3)
5945             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5946           endif
5947           do j=1,3
5948             v1ij=v1(j+1,itori,itori1)
5949             v2ij=v2(j+1,itori,itori1)
5950             cosphi=dcos(j*phii)
5951             sinphi=dsin(j*phii)
5952             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5953             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5954           enddo
5955         else
5956           do j=1,nterm_old
5957             v1ij=v1(j,itori,itori1)
5958             v2ij=v2(j,itori,itori1)
5959             cosphi=dcos(j*phii)
5960             sinphi=dsin(j*phii)
5961             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5962             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5963           enddo
5964         endif
5965         if (lprn)
5966      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5967      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5968      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5969         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5970 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5971       enddo
5972 ! 6/20/98 - dihedral angle constraints
5973       edihcnstr=0.0d0
5974       do i=1,ndih_constr
5975         itori=idih_constr(i)
5976         phii=phi(itori)
5977         difi=pinorm(phii-phi0(i))
5978         if (difi.gt.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         else if (difi.lt.-drange(i)) then
5983           difi=difi+drange(i)
5984           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5985           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5986         endif
5987 c        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5988 c     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5989       enddo
5990       write (iout,*) 'edihcnstr',edihcnstr
5991       return
5992       end
5993 c------------------------------------------------------------------------------
5994 #else
5995       subroutine etor(etors,edihcnstr,fact)
5996       implicit real*8 (a-h,o-z)
5997       include 'DIMENSIONS'
5998       include 'sizesclu.dat'
5999       include 'COMMON.VAR'
6000       include 'COMMON.GEO'
6001       include 'COMMON.LOCAL'
6002       include 'COMMON.TORSION'
6003       include 'COMMON.INTERACT'
6004       include 'COMMON.DERIV'
6005       include 'COMMON.CHAIN'
6006       include 'COMMON.NAMES'
6007       include 'COMMON.IOUNITS'
6008       include 'COMMON.FFIELD'
6009       include 'COMMON.TORCNSTR'
6010       logical lprn
6011 C Set lprn=.true. for debugging
6012       lprn=.false.
6013 c      lprn=.true.
6014       etors=0.0D0
6015       do i=iphi_start,iphi_end
6016         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
6017         itori=itortyp(itype(i-2))
6018         itori1=itortyp(itype(i-1))
6019         phii=phi(i)
6020         gloci=0.0D0
6021 C Regular cosine and sine terms
6022         do j=1,nterm(itori,itori1)
6023           v1ij=v1(j,itori,itori1)
6024           v2ij=v2(j,itori,itori1)
6025           cosphi=dcos(j*phii)
6026           sinphi=dsin(j*phii)
6027           etors=etors+v1ij*cosphi+v2ij*sinphi
6028           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6029         enddo
6030 C Lorentz terms
6031 C                         v1
6032 C  E = SUM ----------------------------------- - v1
6033 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6034 C
6035         cosphi=dcos(0.5d0*phii)
6036         sinphi=dsin(0.5d0*phii)
6037         do j=1,nlor(itori,itori1)
6038           vl1ij=vlor1(j,itori,itori1)
6039           vl2ij=vlor2(j,itori,itori1)
6040           vl3ij=vlor3(j,itori,itori1)
6041           pom=vl2ij*cosphi+vl3ij*sinphi
6042           pom1=1.0d0/(pom*pom+1.0d0)
6043           etors=etors+vl1ij*pom1
6044           pom=-pom*pom1*pom1
6045           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6046         enddo
6047 C Subtract the constant term
6048         etors=etors-v0(itori,itori1)
6049         if (lprn)
6050      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6051      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6052      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6053         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6054 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6055  1215   continue
6056       enddo
6057 ! 6/20/98 - dihedral angle constraints
6058       edihcnstr=0.0d0
6059 c      write (iout,*) "Dihedral angle restraint energy"
6060       do i=1,ndih_constr
6061         itori=idih_constr(i)
6062         phii=phi(itori)
6063         difi=pinorm(phii-phi0(i))
6064 c        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6065 c     &    rad2deg*difi,rad2deg*phi0(i),rad2deg*drange(i)
6066         if (difi.gt.drange(i)) then
6067           difi=difi-drange(i)
6068           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6069           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6070 c          write (iout,*) 0.25d0*ftors*difi**4
6071         else if (difi.lt.-drange(i)) then
6072           difi=difi+drange(i)
6073           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6074           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6075 c          write (iout,*) 0.25d0*ftors*difi**4
6076         endif
6077       enddo
6078 c      write (iout,*) 'edihcnstr',edihcnstr
6079       return
6080       end
6081 c----------------------------------------------------------------------------
6082       subroutine etor_d(etors_d,fact2)
6083 C 6/23/01 Compute double torsional energy
6084       implicit real*8 (a-h,o-z)
6085       include 'DIMENSIONS'
6086       include 'sizesclu.dat'
6087       include 'COMMON.VAR'
6088       include 'COMMON.GEO'
6089       include 'COMMON.LOCAL'
6090       include 'COMMON.TORSION'
6091       include 'COMMON.INTERACT'
6092       include 'COMMON.DERIV'
6093       include 'COMMON.CHAIN'
6094       include 'COMMON.NAMES'
6095       include 'COMMON.IOUNITS'
6096       include 'COMMON.FFIELD'
6097       include 'COMMON.TORCNSTR'
6098       logical lprn
6099 C Set lprn=.true. for debugging
6100       lprn=.false.
6101 c     lprn=.true.
6102       etors_d=0.0D0
6103       do i=iphi_start,iphi_end-1
6104         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6105      &     goto 1215
6106         itori=itortyp(itype(i-2))
6107         itori1=itortyp(itype(i-1))
6108         itori2=itortyp(itype(i))
6109         phii=phi(i)
6110         phii1=phi(i+1)
6111         gloci1=0.0D0
6112         gloci2=0.0D0
6113 C Regular cosine and sine terms
6114         do j=1,ntermd_1(itori,itori1,itori2)
6115           v1cij=v1c(1,j,itori,itori1,itori2)
6116           v1sij=v1s(1,j,itori,itori1,itori2)
6117           v2cij=v1c(2,j,itori,itori1,itori2)
6118           v2sij=v1s(2,j,itori,itori1,itori2)
6119           cosphi1=dcos(j*phii)
6120           sinphi1=dsin(j*phii)
6121           cosphi2=dcos(j*phii1)
6122           sinphi2=dsin(j*phii1)
6123           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6124      &     v2cij*cosphi2+v2sij*sinphi2
6125           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6126           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6127         enddo
6128         do k=2,ntermd_2(itori,itori1,itori2)
6129           do l=1,k-1
6130             v1cdij = v2c(k,l,itori,itori1,itori2)
6131             v2cdij = v2c(l,k,itori,itori1,itori2)
6132             v1sdij = v2s(k,l,itori,itori1,itori2)
6133             v2sdij = v2s(l,k,itori,itori1,itori2)
6134             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6135             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6136             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6137             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6138             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6139      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6140             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6141      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6142             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6143      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6144           enddo
6145         enddo
6146         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6147         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6148  1215   continue
6149       enddo
6150       return
6151       end
6152 #endif
6153 c------------------------------------------------------------------------------
6154       subroutine eback_sc_corr(esccor,fact)
6155 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6156 c        conformational states; temporarily implemented as differences
6157 c        between UNRES torsional potentials (dependent on three types of
6158 c        residues) and the torsional potentials dependent on all 20 types
6159 c        of residues computed from AM1 energy surfaces of terminally-blocked
6160 c        amino-acid residues.
6161       implicit real*8 (a-h,o-z)
6162       include 'DIMENSIONS'
6163       include 'COMMON.VAR'
6164       include 'COMMON.GEO'
6165       include 'COMMON.LOCAL'
6166       include 'COMMON.TORSION'
6167       include 'COMMON.SCCOR'
6168       include 'COMMON.INTERACT'
6169       include 'COMMON.DERIV'
6170       include 'COMMON.CHAIN'
6171       include 'COMMON.NAMES'
6172       include 'COMMON.IOUNITS'
6173       include 'COMMON.FFIELD'
6174       include 'COMMON.CONTROL'
6175       logical lprn
6176 C Set lprn=.true. for debugging
6177       lprn=.false.
6178 c      lprn=.true.
6179 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6180       esccor=0.0D0
6181       do i=itau_start,itau_end
6182         esccor_ii=0.0D0
6183         isccori=isccortyp(itype(i-2))
6184         isccori1=isccortyp(itype(i-1))
6185         phii=phi(i)
6186 cccc  Added 9 May 2012
6187 cc Tauangle is torsional engle depending on the value of first digit
6188 c(see comment below)
6189 cc Omicron is flat angle depending on the value of first digit
6190 c(see comment below)
6191
6192
6193         do intertyp=1,3 !intertyp
6194 cc Added 09 May 2012 (Adasko)
6195 cc  Intertyp means interaction type of backbone mainchain correlation:
6196 c   1 = SC...Ca...Ca...Ca
6197 c   2 = Ca...Ca...Ca...SC
6198 c   3 = SC...Ca...Ca...SCi
6199         gloci=0.0D0
6200         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6201      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6202      &      (itype(i-1).eq.21)))
6203      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6204      &     .or.(itype(i-2).eq.21)))
6205      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6206      &      (itype(i-1).eq.21)))) cycle
6207         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6208         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6209      & cycle
6210         do j=1,nterm_sccor(isccori,isccori1)
6211           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6212           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6213           cosphi=dcos(j*tauangle(intertyp,i))
6214           sinphi=dsin(j*tauangle(intertyp,i))
6215           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6216           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6217         enddo
6218         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6219 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6220 c     &gloc_sc(intertyp,i-3,icg)
6221         if (lprn)
6222      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6223      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6224      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6225      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6226         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6227        enddo !intertyp
6228       enddo
6229
6230       return
6231       end
6232 c------------------------------------------------------------------------------
6233       subroutine multibody(ecorr)
6234 C This subroutine calculates multi-body contributions to energy following
6235 C the idea of Skolnick et al. If side chains I and J make a contact and
6236 C at the same time side chains I+1 and J+1 make a contact, an extra
6237 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6238       implicit real*8 (a-h,o-z)
6239       include 'DIMENSIONS'
6240       include 'COMMON.IOUNITS'
6241       include 'COMMON.DERIV'
6242       include 'COMMON.INTERACT'
6243       include 'COMMON.CONTACTS'
6244       double precision gx(3),gx1(3)
6245       logical lprn
6246
6247 C Set lprn=.true. for debugging
6248       lprn=.false.
6249
6250       if (lprn) then
6251         write (iout,'(a)') 'Contact function values:'
6252         do i=nnt,nct-2
6253           write (iout,'(i2,20(1x,i2,f10.5))')
6254      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6255         enddo
6256       endif
6257       ecorr=0.0D0
6258       do i=nnt,nct
6259         do j=1,3
6260           gradcorr(j,i)=0.0D0
6261           gradxorr(j,i)=0.0D0
6262         enddo
6263       enddo
6264       do i=nnt,nct-2
6265
6266         DO ISHIFT = 3,4
6267
6268         i1=i+ishift
6269         num_conti=num_cont(i)
6270         num_conti1=num_cont(i1)
6271         do jj=1,num_conti
6272           j=jcont(jj,i)
6273           do kk=1,num_conti1
6274             j1=jcont(kk,i1)
6275             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6276 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6277 cd   &                   ' ishift=',ishift
6278 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6279 C The system gains extra energy.
6280               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6281             endif   ! j1==j+-ishift
6282           enddo     ! kk
6283         enddo       ! jj
6284
6285         ENDDO ! ISHIFT
6286
6287       enddo         ! i
6288       return
6289       end
6290 c------------------------------------------------------------------------------
6291       double precision function esccorr(i,j,k,l,jj,kk)
6292       implicit real*8 (a-h,o-z)
6293       include 'DIMENSIONS'
6294       include 'COMMON.IOUNITS'
6295       include 'COMMON.DERIV'
6296       include 'COMMON.INTERACT'
6297       include 'COMMON.CONTACTS'
6298       double precision gx(3),gx1(3)
6299       logical lprn
6300       lprn=.false.
6301       eij=facont(jj,i)
6302       ekl=facont(kk,k)
6303 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6304 C Calculate the multi-body contribution to energy.
6305 C Calculate multi-body contributions to the gradient.
6306 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6307 cd   & k,l,(gacont(m,kk,k),m=1,3)
6308       do m=1,3
6309         gx(m) =ekl*gacont(m,jj,i)
6310         gx1(m)=eij*gacont(m,kk,k)
6311         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6312         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6313         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6314         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6315       enddo
6316       do m=i,j-1
6317         do ll=1,3
6318           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6319         enddo
6320       enddo
6321       do m=k,l-1
6322         do ll=1,3
6323           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6324         enddo
6325       enddo
6326       esccorr=-eij*ekl
6327       return
6328       end
6329 c------------------------------------------------------------------------------
6330 #ifdef MPL
6331       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
6332       implicit real*8 (a-h,o-z)
6333       include 'DIMENSIONS'
6334       integer dimen1,dimen2,atom,indx
6335       double precision buffer(dimen1,dimen2)
6336       double precision zapas
6337       common /contacts_hb/ zapas(3,20,maxres,7),
6338      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6339      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6340       num_kont=num_cont_hb(atom)
6341       do i=1,num_kont
6342         do k=1,7
6343           do j=1,3
6344             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
6345           enddo ! j
6346         enddo ! k
6347         buffer(i,indx+22)=facont_hb(i,atom)
6348         buffer(i,indx+23)=ees0p(i,atom)
6349         buffer(i,indx+24)=ees0m(i,atom)
6350         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
6351       enddo ! i
6352       buffer(1,indx+26)=dfloat(num_kont)
6353       return
6354       end
6355 c------------------------------------------------------------------------------
6356       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
6357       implicit real*8 (a-h,o-z)
6358       include 'DIMENSIONS'
6359       integer dimen1,dimen2,atom,indx
6360       double precision buffer(dimen1,dimen2)
6361       double precision zapas
6362       common /contacts_hb/ zapas(3,20,maxres,7),
6363      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6364      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6365       num_kont=buffer(1,indx+26)
6366       num_kont_old=num_cont_hb(atom)
6367       num_cont_hb(atom)=num_kont+num_kont_old
6368       do i=1,num_kont
6369         ii=i+num_kont_old
6370         do k=1,7
6371           do j=1,3
6372             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
6373           enddo ! j
6374         enddo ! k
6375         facont_hb(ii,atom)=buffer(i,indx+22)
6376         ees0p(ii,atom)=buffer(i,indx+23)
6377         ees0m(ii,atom)=buffer(i,indx+24)
6378         jcont_hb(ii,atom)=buffer(i,indx+25)
6379       enddo ! i
6380       return
6381       end
6382 c------------------------------------------------------------------------------
6383 #endif
6384       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6385 C This subroutine calculates multi-body contributions to hydrogen-bonding
6386       implicit real*8 (a-h,o-z)
6387       include 'DIMENSIONS'
6388       include 'sizesclu.dat'
6389       include 'COMMON.IOUNITS'
6390 #ifdef MPL
6391       include 'COMMON.INFO'
6392 #endif
6393       include 'COMMON.FFIELD'
6394       include 'COMMON.DERIV'
6395       include 'COMMON.INTERACT'
6396       include 'COMMON.CONTACTS'
6397 #ifdef MPL
6398       parameter (max_cont=maxconts)
6399       parameter (max_dim=2*(8*3+2))
6400       parameter (msglen1=max_cont*max_dim*4)
6401       parameter (msglen2=2*msglen1)
6402       integer source,CorrelType,CorrelID,Error
6403       double precision buffer(max_cont,max_dim)
6404 #endif
6405       double precision gx(3),gx1(3)
6406       logical lprn,ldone
6407
6408 C Set lprn=.true. for debugging
6409       lprn=.false.
6410 #ifdef MPL
6411       n_corr=0
6412       n_corr1=0
6413       if (fgProcs.le.1) goto 30
6414       if (lprn) then
6415         write (iout,'(a)') 'Contact function values:'
6416         do i=nnt,nct-2
6417           write (iout,'(2i3,50(1x,i2,f5.2))')
6418      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6419      &    j=1,num_cont_hb(i))
6420         enddo
6421       endif
6422 C Caution! Following code assumes that electrostatic interactions concerning
6423 C a given atom are split among at most two processors!
6424       CorrelType=477
6425       CorrelID=MyID+1
6426       ldone=.false.
6427       do i=1,max_cont
6428         do j=1,max_dim
6429           buffer(i,j)=0.0D0
6430         enddo
6431       enddo
6432       mm=mod(MyRank,2)
6433 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6434       if (mm) 20,20,10
6435    10 continue
6436 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6437       if (MyRank.gt.0) then
6438 C Send correlation contributions to the preceding processor
6439         msglen=msglen1
6440         nn=num_cont_hb(iatel_s)
6441         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6442 cd      write (iout,*) 'The BUFFER array:'
6443 cd      do i=1,nn
6444 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6445 cd      enddo
6446         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6447           msglen=msglen2
6448             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6449 C Clear the contacts of the atom passed to the neighboring processor
6450         nn=num_cont_hb(iatel_s+1)
6451 cd      do i=1,nn
6452 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6453 cd      enddo
6454             num_cont_hb(iatel_s)=0
6455         endif
6456 cd      write (iout,*) 'Processor ',MyID,MyRank,
6457 cd   & ' is sending correlation contribution to processor',MyID-1,
6458 cd   & ' msglen=',msglen
6459 cd      write (*,*) 'Processor ',MyID,MyRank,
6460 cd   & ' is sending correlation contribution to processor',MyID-1,
6461 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6462         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6463 cd      write (iout,*) 'Processor ',MyID,
6464 cd   & ' has sent correlation contribution to processor',MyID-1,
6465 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6466 cd      write (*,*) 'Processor ',MyID,
6467 cd   & ' has sent correlation contribution to processor',MyID-1,
6468 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6469         msglen=msglen1
6470       endif ! (MyRank.gt.0)
6471       if (ldone) goto 30
6472       ldone=.true.
6473    20 continue
6474 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6475       if (MyRank.lt.fgProcs-1) then
6476 C Receive correlation contributions from the next processor
6477         msglen=msglen1
6478         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6479 cd      write (iout,*) 'Processor',MyID,
6480 cd   & ' is receiving correlation contribution from processor',MyID+1,
6481 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6482 cd      write (*,*) 'Processor',MyID,
6483 cd   & ' is receiving correlation contribution from processor',MyID+1,
6484 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6485         nbytes=-1
6486         do while (nbytes.le.0)
6487           call mp_probe(MyID+1,CorrelType,nbytes)
6488         enddo
6489 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6490         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6491 cd      write (iout,*) 'Processor',MyID,
6492 cd   & ' has received correlation contribution from processor',MyID+1,
6493 cd   & ' msglen=',msglen,' nbytes=',nbytes
6494 cd      write (iout,*) 'The received BUFFER array:'
6495 cd      do i=1,max_cont
6496 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6497 cd      enddo
6498         if (msglen.eq.msglen1) then
6499           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6500         else if (msglen.eq.msglen2)  then
6501           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6502           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6503         else
6504           write (iout,*)
6505      & 'ERROR!!!! message length changed while processing correlations.'
6506           write (*,*)
6507      & 'ERROR!!!! message length changed while processing correlations.'
6508           call mp_stopall(Error)
6509         endif ! msglen.eq.msglen1
6510       endif ! MyRank.lt.fgProcs-1
6511       if (ldone) goto 30
6512       ldone=.true.
6513       goto 10
6514    30 continue
6515 #endif
6516       if (lprn) then
6517         write (iout,'(a)') 'Contact function values:'
6518         do i=nnt,nct-2
6519           write (iout,'(2i3,50(1x,i2,f5.2))')
6520      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6521      &    j=1,num_cont_hb(i))
6522         enddo
6523       endif
6524       ecorr=0.0D0
6525 C Remove the loop below after debugging !!!
6526       do i=nnt,nct
6527         do j=1,3
6528           gradcorr(j,i)=0.0D0
6529           gradxorr(j,i)=0.0D0
6530         enddo
6531       enddo
6532 C Calculate the local-electrostatic correlation terms
6533       do i=iatel_s,iatel_e+1
6534         i1=i+1
6535         num_conti=num_cont_hb(i)
6536         num_conti1=num_cont_hb(i+1)
6537         do jj=1,num_conti
6538           j=jcont_hb(jj,i)
6539           do kk=1,num_conti1
6540             j1=jcont_hb(kk,i1)
6541 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6542 c     &         ' jj=',jj,' kk=',kk
6543             if (j1.eq.j+1 .or. j1.eq.j-1) then
6544 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6545 C The system gains extra energy.
6546               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6547               n_corr=n_corr+1
6548             else if (j1.eq.j) then
6549 C Contacts I-J and I-(J+1) occur simultaneously.
6550 C The system loses extra energy.
6551 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6552             endif
6553           enddo ! kk
6554           do kk=1,num_conti
6555             j1=jcont_hb(kk,i)
6556 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6557 c    &         ' jj=',jj,' kk=',kk
6558             if (j1.eq.j+1) then
6559 C Contacts I-J and (I+1)-J occur simultaneously.
6560 C The system loses extra energy.
6561 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6562             endif ! j1==j+1
6563           enddo ! kk
6564         enddo ! jj
6565       enddo ! i
6566       return
6567       end
6568 c------------------------------------------------------------------------------
6569       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6570      &  n_corr1)
6571 C This subroutine calculates multi-body contributions to hydrogen-bonding
6572       implicit real*8 (a-h,o-z)
6573       include 'DIMENSIONS'
6574       include 'sizesclu.dat'
6575       include 'COMMON.IOUNITS'
6576 #ifdef MPL
6577       include 'COMMON.INFO'
6578 #endif
6579       include 'COMMON.FFIELD'
6580       include 'COMMON.DERIV'
6581       include 'COMMON.INTERACT'
6582       include 'COMMON.CONTACTS'
6583 #ifdef MPL
6584       parameter (max_cont=maxconts)
6585       parameter (max_dim=2*(8*3+2))
6586       parameter (msglen1=max_cont*max_dim*4)
6587       parameter (msglen2=2*msglen1)
6588       integer source,CorrelType,CorrelID,Error
6589       double precision buffer(max_cont,max_dim)
6590 #endif
6591       double precision gx(3),gx1(3)
6592       logical lprn,ldone
6593
6594 C Set lprn=.true. for debugging
6595       lprn=.false.
6596       eturn6=0.0d0
6597 #ifdef MPL
6598       n_corr=0
6599       n_corr1=0
6600       if (fgProcs.le.1) goto 30
6601       if (lprn) then
6602         write (iout,'(a)') 'Contact function values:'
6603         do i=nnt,nct-2
6604           write (iout,'(2i3,50(1x,i2,f5.2))')
6605      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6606      &    j=1,num_cont_hb(i))
6607         enddo
6608       endif
6609 C Caution! Following code assumes that electrostatic interactions concerning
6610 C a given atom are split among at most two processors!
6611       CorrelType=477
6612       CorrelID=MyID+1
6613       ldone=.false.
6614       do i=1,max_cont
6615         do j=1,max_dim
6616           buffer(i,j)=0.0D0
6617         enddo
6618       enddo
6619       mm=mod(MyRank,2)
6620 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6621       if (mm) 20,20,10
6622    10 continue
6623 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6624       if (MyRank.gt.0) then
6625 C Send correlation contributions to the preceding processor
6626         msglen=msglen1
6627         nn=num_cont_hb(iatel_s)
6628         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6629 cd      write (iout,*) 'The BUFFER array:'
6630 cd      do i=1,nn
6631 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6632 cd      enddo
6633         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6634           msglen=msglen2
6635             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6636 C Clear the contacts of the atom passed to the neighboring processor
6637         nn=num_cont_hb(iatel_s+1)
6638 cd      do i=1,nn
6639 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6640 cd      enddo
6641             num_cont_hb(iatel_s)=0
6642         endif
6643 cd      write (iout,*) 'Processor ',MyID,MyRank,
6644 cd   & ' is sending correlation contribution to processor',MyID-1,
6645 cd   & ' msglen=',msglen
6646 cd      write (*,*) 'Processor ',MyID,MyRank,
6647 cd   & ' is sending correlation contribution to processor',MyID-1,
6648 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6649         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6650 cd      write (iout,*) 'Processor ',MyID,
6651 cd   & ' has sent correlation contribution to processor',MyID-1,
6652 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6653 cd      write (*,*) 'Processor ',MyID,
6654 cd   & ' has sent correlation contribution to processor',MyID-1,
6655 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6656         msglen=msglen1
6657       endif ! (MyRank.gt.0)
6658       if (ldone) goto 30
6659       ldone=.true.
6660    20 continue
6661 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6662       if (MyRank.lt.fgProcs-1) then
6663 C Receive correlation contributions from the next processor
6664         msglen=msglen1
6665         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6666 cd      write (iout,*) 'Processor',MyID,
6667 cd   & ' is receiving correlation contribution from processor',MyID+1,
6668 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6669 cd      write (*,*) 'Processor',MyID,
6670 cd   & ' is receiving correlation contribution from processor',MyID+1,
6671 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6672         nbytes=-1
6673         do while (nbytes.le.0)
6674           call mp_probe(MyID+1,CorrelType,nbytes)
6675         enddo
6676 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6677         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6678 cd      write (iout,*) 'Processor',MyID,
6679 cd   & ' has received correlation contribution from processor',MyID+1,
6680 cd   & ' msglen=',msglen,' nbytes=',nbytes
6681 cd      write (iout,*) 'The received BUFFER array:'
6682 cd      do i=1,max_cont
6683 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6684 cd      enddo
6685         if (msglen.eq.msglen1) then
6686           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6687         else if (msglen.eq.msglen2)  then
6688           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6689           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6690         else
6691           write (iout,*)
6692      & 'ERROR!!!! message length changed while processing correlations.'
6693           write (*,*)
6694      & 'ERROR!!!! message length changed while processing correlations.'
6695           call mp_stopall(Error)
6696         endif ! msglen.eq.msglen1
6697       endif ! MyRank.lt.fgProcs-1
6698       if (ldone) goto 30
6699       ldone=.true.
6700       goto 10
6701    30 continue
6702 #endif
6703       if (lprn) then
6704         write (iout,'(a)') 'Contact function values:'
6705         do i=nnt,nct-2
6706           write (iout,'(2i3,50(1x,i2,f5.2))')
6707      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6708      &    j=1,num_cont_hb(i))
6709         enddo
6710       endif
6711       ecorr=0.0D0
6712       ecorr5=0.0d0
6713       ecorr6=0.0d0
6714 C Remove the loop below after debugging !!!
6715       do i=nnt,nct
6716         do j=1,3
6717           gradcorr(j,i)=0.0D0
6718           gradxorr(j,i)=0.0D0
6719         enddo
6720       enddo
6721 C Calculate the dipole-dipole interaction energies
6722       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6723       do i=iatel_s,iatel_e+1
6724         num_conti=num_cont_hb(i)
6725         do jj=1,num_conti
6726           j=jcont_hb(jj,i)
6727           call dipole(i,j,jj)
6728         enddo
6729       enddo
6730       endif
6731 C Calculate the local-electrostatic correlation terms
6732       do i=iatel_s,iatel_e+1
6733         i1=i+1
6734         num_conti=num_cont_hb(i)
6735         num_conti1=num_cont_hb(i+1)
6736         do jj=1,num_conti
6737           j=jcont_hb(jj,i)
6738           do kk=1,num_conti1
6739             j1=jcont_hb(kk,i1)
6740 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6741 c     &         ' jj=',jj,' kk=',kk
6742             if (j1.eq.j+1 .or. j1.eq.j-1) then
6743 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6744 C The system gains extra energy.
6745               n_corr=n_corr+1
6746               sqd1=dsqrt(d_cont(jj,i))
6747               sqd2=dsqrt(d_cont(kk,i1))
6748               sred_geom = sqd1*sqd2
6749               IF (sred_geom.lt.cutoff_corr) THEN
6750                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6751      &            ekont,fprimcont)
6752 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6753 c     &         ' jj=',jj,' kk=',kk
6754                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6755                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6756                 do l=1,3
6757                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6758                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6759                 enddo
6760                 n_corr1=n_corr1+1
6761 cd               write (iout,*) 'sred_geom=',sred_geom,
6762 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6763                 call calc_eello(i,j,i+1,j1,jj,kk)
6764                 if (wcorr4.gt.0.0d0)
6765      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6766                 if (wcorr5.gt.0.0d0)
6767      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6768 c                print *,"wcorr5",ecorr5
6769 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6770 cd                write(2,*)'ijkl',i,j,i+1,j1
6771                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6772      &               .or. wturn6.eq.0.0d0))then
6773 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6774                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6775 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6776 cd     &            'ecorr6=',ecorr6
6777 cd                write (iout,'(4e15.5)') sred_geom,
6778 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6779 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6780 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6781                 else if (wturn6.gt.0.0d0
6782      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6783 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6784                   eturn6=eturn6+eello_turn6(i,jj,kk)
6785 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6786                 endif
6787               ENDIF
6788 1111          continue
6789             else if (j1.eq.j) then
6790 C Contacts I-J and I-(J+1) occur simultaneously.
6791 C The system loses extra energy.
6792 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6793             endif
6794           enddo ! kk
6795           do kk=1,num_conti
6796             j1=jcont_hb(kk,i)
6797 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6798 c    &         ' jj=',jj,' kk=',kk
6799             if (j1.eq.j+1) then
6800 C Contacts I-J and (I+1)-J occur simultaneously.
6801 C The system loses extra energy.
6802 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6803             endif ! j1==j+1
6804           enddo ! kk
6805         enddo ! jj
6806       enddo ! i
6807       return
6808       end
6809 c------------------------------------------------------------------------------
6810       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6811       implicit real*8 (a-h,o-z)
6812       include 'DIMENSIONS'
6813       include 'COMMON.IOUNITS'
6814       include 'COMMON.DERIV'
6815       include 'COMMON.INTERACT'
6816       include 'COMMON.CONTACTS'
6817       double precision gx(3),gx1(3)
6818       logical lprn
6819       lprn=.false.
6820       eij=facont_hb(jj,i)
6821       ekl=facont_hb(kk,k)
6822       ees0pij=ees0p(jj,i)
6823       ees0pkl=ees0p(kk,k)
6824       ees0mij=ees0m(jj,i)
6825       ees0mkl=ees0m(kk,k)
6826       ekont=eij*ekl
6827       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6828 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6829 C Following 4 lines for diagnostics.
6830 cd    ees0pkl=0.0D0
6831 cd    ees0pij=1.0D0
6832 cd    ees0mkl=0.0D0
6833 cd    ees0mij=1.0D0
6834 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6835 c    &   ' and',k,l
6836 c     write (iout,*)'Contacts have occurred for peptide groups',
6837 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6838 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6839 C Calculate the multi-body contribution to energy.
6840       ecorr=ecorr+ekont*ees
6841       if (calc_grad) then
6842 C Calculate multi-body contributions to the gradient.
6843       do ll=1,3
6844         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6845         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6846      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6847      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6848         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6849      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6850      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6851         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6852         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6853      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6854      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6855         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6856      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6857      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6858       enddo
6859       do m=i+1,j-1
6860         do ll=1,3
6861           gradcorr(ll,m)=gradcorr(ll,m)+
6862      &     ees*ekl*gacont_hbr(ll,jj,i)-
6863      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6864      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6865         enddo
6866       enddo
6867       do m=k+1,l-1
6868         do ll=1,3
6869           gradcorr(ll,m)=gradcorr(ll,m)+
6870      &     ees*eij*gacont_hbr(ll,kk,k)-
6871      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6872      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6873         enddo
6874       enddo
6875       endif
6876       ehbcorr=ekont*ees
6877       return
6878       end
6879 C---------------------------------------------------------------------------
6880       subroutine dipole(i,j,jj)
6881       implicit real*8 (a-h,o-z)
6882       include 'DIMENSIONS'
6883       include 'sizesclu.dat'
6884       include 'COMMON.IOUNITS'
6885       include 'COMMON.CHAIN'
6886       include 'COMMON.FFIELD'
6887       include 'COMMON.DERIV'
6888       include 'COMMON.INTERACT'
6889       include 'COMMON.CONTACTS'
6890       include 'COMMON.TORSION'
6891       include 'COMMON.VAR'
6892       include 'COMMON.GEO'
6893       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6894      &  auxmat(2,2)
6895       iti1 = itortyp(itype(i+1))
6896       if (j.lt.nres-1) then
6897         itj1 = itortyp(itype(j+1))
6898       else
6899         itj1=ntortyp+1
6900       endif
6901       do iii=1,2
6902         dipi(iii,1)=Ub2(iii,i)
6903         dipderi(iii)=Ub2der(iii,i)
6904         dipi(iii,2)=b1(iii,iti1)
6905         dipj(iii,1)=Ub2(iii,j)
6906         dipderj(iii)=Ub2der(iii,j)
6907         dipj(iii,2)=b1(iii,itj1)
6908       enddo
6909       kkk=0
6910       do iii=1,2
6911         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6912         do jjj=1,2
6913           kkk=kkk+1
6914           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6915         enddo
6916       enddo
6917       if (.not.calc_grad) return
6918       do kkk=1,5
6919         do lll=1,3
6920           mmm=0
6921           do iii=1,2
6922             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6923      &        auxvec(1))
6924             do jjj=1,2
6925               mmm=mmm+1
6926               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6927             enddo
6928           enddo
6929         enddo
6930       enddo
6931       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6932       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6933       do iii=1,2
6934         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6935       enddo
6936       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6937       do iii=1,2
6938         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6939       enddo
6940       return
6941       end
6942 C---------------------------------------------------------------------------
6943       subroutine calc_eello(i,j,k,l,jj,kk)
6944 C
6945 C This subroutine computes matrices and vectors needed to calculate
6946 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6947 C
6948       implicit real*8 (a-h,o-z)
6949       include 'DIMENSIONS'
6950       include 'sizesclu.dat'
6951       include 'COMMON.IOUNITS'
6952       include 'COMMON.CHAIN'
6953       include 'COMMON.DERIV'
6954       include 'COMMON.INTERACT'
6955       include 'COMMON.CONTACTS'
6956       include 'COMMON.TORSION'
6957       include 'COMMON.VAR'
6958       include 'COMMON.GEO'
6959       include 'COMMON.FFIELD'
6960       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6961      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6962       logical lprn
6963       common /kutas/ lprn
6964 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6965 cd     & ' jj=',jj,' kk=',kk
6966 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6967       do iii=1,2
6968         do jjj=1,2
6969           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6970           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6971         enddo
6972       enddo
6973       call transpose2(aa1(1,1),aa1t(1,1))
6974       call transpose2(aa2(1,1),aa2t(1,1))
6975       do kkk=1,5
6976         do lll=1,3
6977           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6978      &      aa1tder(1,1,lll,kkk))
6979           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6980      &      aa2tder(1,1,lll,kkk))
6981         enddo
6982       enddo
6983       if (l.eq.j+1) then
6984 C parallel orientation of the two CA-CA-CA frames.
6985         if (i.gt.1) then
6986           iti=itortyp(itype(i))
6987         else
6988           iti=ntortyp+1
6989         endif
6990         itk1=itortyp(itype(k+1))
6991         itj=itortyp(itype(j))
6992         if (l.lt.nres-1) then
6993           itl1=itortyp(itype(l+1))
6994         else
6995           itl1=ntortyp+1
6996         endif
6997 C A1 kernel(j+1) A2T
6998 cd        do iii=1,2
6999 cd          write (iout,'(3f10.5,5x,3f10.5)')
7000 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7001 cd        enddo
7002         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7003      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7004      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7005 C Following matrices are needed only for 6-th order cumulants
7006         IF (wcorr6.gt.0.0d0) THEN
7007         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7008      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7009      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7010         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7011      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7012      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7013      &   ADtEAderx(1,1,1,1,1,1))
7014         lprn=.false.
7015         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7016      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7017      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7018      &   ADtEA1derx(1,1,1,1,1,1))
7019         ENDIF
7020 C End 6-th order cumulants
7021 cd        lprn=.false.
7022 cd        if (lprn) then
7023 cd        write (2,*) 'In calc_eello6'
7024 cd        do iii=1,2
7025 cd          write (2,*) 'iii=',iii
7026 cd          do kkk=1,5
7027 cd            write (2,*) 'kkk=',kkk
7028 cd            do jjj=1,2
7029 cd              write (2,'(3(2f10.5),5x)')
7030 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7031 cd            enddo
7032 cd          enddo
7033 cd        enddo
7034 cd        endif
7035         call transpose2(EUgder(1,1,k),auxmat(1,1))
7036         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7037         call transpose2(EUg(1,1,k),auxmat(1,1))
7038         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7039         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7040         do iii=1,2
7041           do kkk=1,5
7042             do lll=1,3
7043               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7044      &          EAEAderx(1,1,lll,kkk,iii,1))
7045             enddo
7046           enddo
7047         enddo
7048 C A1T kernel(i+1) A2
7049         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7050      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7051      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7052 C Following matrices are needed only for 6-th order cumulants
7053         IF (wcorr6.gt.0.0d0) THEN
7054         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7055      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7056      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(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.,Ug2DtEUg(1,1,k),
7059      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7060      &   ADtEAderx(1,1,1,1,1,2))
7061         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7062      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7063      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7064      &   ADtEA1derx(1,1,1,1,1,2))
7065         ENDIF
7066 C End 6-th order cumulants
7067         call transpose2(EUgder(1,1,l),auxmat(1,1))
7068         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7069         call transpose2(EUg(1,1,l),auxmat(1,1))
7070         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7071         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7072         do iii=1,2
7073           do kkk=1,5
7074             do lll=1,3
7075               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7076      &          EAEAderx(1,1,lll,kkk,iii,2))
7077             enddo
7078           enddo
7079         enddo
7080 C AEAb1 and AEAb2
7081 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7082 C They are needed only when the fifth- or the sixth-order cumulants are
7083 C indluded.
7084         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7085         call transpose2(AEA(1,1,1),auxmat(1,1))
7086         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7087         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7088         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7089         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7090         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7091         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7092         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7093         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7094         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7095         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7096         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7097         call transpose2(AEA(1,1,2),auxmat(1,1))
7098         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7099         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7100         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7101         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7102         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7103         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7104         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7105         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7106         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7107         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7108         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7109 C Calculate the Cartesian derivatives of the vectors.
7110         do iii=1,2
7111           do kkk=1,5
7112             do lll=1,3
7113               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7114               call matvec2(auxmat(1,1),b1(1,iti),
7115      &          AEAb1derx(1,lll,kkk,iii,1,1))
7116               call matvec2(auxmat(1,1),Ub2(1,i),
7117      &          AEAb2derx(1,lll,kkk,iii,1,1))
7118               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7119      &          AEAb1derx(1,lll,kkk,iii,2,1))
7120               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7121      &          AEAb2derx(1,lll,kkk,iii,2,1))
7122               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7123               call matvec2(auxmat(1,1),b1(1,itj),
7124      &          AEAb1derx(1,lll,kkk,iii,1,2))
7125               call matvec2(auxmat(1,1),Ub2(1,j),
7126      &          AEAb2derx(1,lll,kkk,iii,1,2))
7127               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7128      &          AEAb1derx(1,lll,kkk,iii,2,2))
7129               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7130      &          AEAb2derx(1,lll,kkk,iii,2,2))
7131             enddo
7132           enddo
7133         enddo
7134         ENDIF
7135 C End vectors
7136       else
7137 C Antiparallel orientation of the two CA-CA-CA frames.
7138         if (i.gt.1) then
7139           iti=itortyp(itype(i))
7140         else
7141           iti=ntortyp+1
7142         endif
7143         itk1=itortyp(itype(k+1))
7144         itl=itortyp(itype(l))
7145         itj=itortyp(itype(j))
7146         if (j.lt.nres-1) then
7147           itj1=itortyp(itype(j+1))
7148         else
7149           itj1=ntortyp+1
7150         endif
7151 C A2 kernel(j-1)T A1T
7152         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7153      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7154      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7155 C Following matrices are needed only for 6-th order cumulants
7156         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7157      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7158         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7159      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7160      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7161         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7162      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7163      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7164      &   ADtEAderx(1,1,1,1,1,1))
7165         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7166      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7167      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7168      &   ADtEA1derx(1,1,1,1,1,1))
7169         ENDIF
7170 C End 6-th order cumulants
7171         call transpose2(EUgder(1,1,k),auxmat(1,1))
7172         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7173         call transpose2(EUg(1,1,k),auxmat(1,1))
7174         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7175         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7176         do iii=1,2
7177           do kkk=1,5
7178             do lll=1,3
7179               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7180      &          EAEAderx(1,1,lll,kkk,iii,1))
7181             enddo
7182           enddo
7183         enddo
7184 C A2T kernel(i+1)T A1
7185         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7186      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7187      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7188 C Following matrices are needed only for 6-th order cumulants
7189         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7190      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7191         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7192      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7193      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(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.,Ug2DtEUg(1,1,k),
7196      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7197      &   ADtEAderx(1,1,1,1,1,2))
7198         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7199      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7200      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7201      &   ADtEA1derx(1,1,1,1,1,2))
7202         ENDIF
7203 C End 6-th order cumulants
7204         call transpose2(EUgder(1,1,j),auxmat(1,1))
7205         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7206         call transpose2(EUg(1,1,j),auxmat(1,1))
7207         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7208         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7209         do iii=1,2
7210           do kkk=1,5
7211             do lll=1,3
7212               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7213      &          EAEAderx(1,1,lll,kkk,iii,2))
7214             enddo
7215           enddo
7216         enddo
7217 C AEAb1 and AEAb2
7218 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7219 C They are needed only when the fifth- or the sixth-order cumulants are
7220 C indluded.
7221         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7222      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7223         call transpose2(AEA(1,1,1),auxmat(1,1))
7224         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7225         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7226         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7227         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7228         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7229         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7230         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7231         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7232         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7233         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7234         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7235         call transpose2(AEA(1,1,2),auxmat(1,1))
7236         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7237         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7238         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7239         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7240         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7241         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7242         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7243         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7244         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7245         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7246         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7247 C Calculate the Cartesian derivatives of the vectors.
7248         do iii=1,2
7249           do kkk=1,5
7250             do lll=1,3
7251               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7252               call matvec2(auxmat(1,1),b1(1,iti),
7253      &          AEAb1derx(1,lll,kkk,iii,1,1))
7254               call matvec2(auxmat(1,1),Ub2(1,i),
7255      &          AEAb2derx(1,lll,kkk,iii,1,1))
7256               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7257      &          AEAb1derx(1,lll,kkk,iii,2,1))
7258               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7259      &          AEAb2derx(1,lll,kkk,iii,2,1))
7260               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7261               call matvec2(auxmat(1,1),b1(1,itl),
7262      &          AEAb1derx(1,lll,kkk,iii,1,2))
7263               call matvec2(auxmat(1,1),Ub2(1,l),
7264      &          AEAb2derx(1,lll,kkk,iii,1,2))
7265               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7266      &          AEAb1derx(1,lll,kkk,iii,2,2))
7267               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7268      &          AEAb2derx(1,lll,kkk,iii,2,2))
7269             enddo
7270           enddo
7271         enddo
7272         ENDIF
7273 C End vectors
7274       endif
7275       return
7276       end
7277 C---------------------------------------------------------------------------
7278       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7279      &  KK,KKderg,AKA,AKAderg,AKAderx)
7280       implicit none
7281       integer nderg
7282       logical transp
7283       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7284      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7285      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7286       integer iii,kkk,lll
7287       integer jjj,mmm
7288       logical lprn
7289       common /kutas/ lprn
7290       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7291       do iii=1,nderg
7292         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7293      &    AKAderg(1,1,iii))
7294       enddo
7295 cd      if (lprn) write (2,*) 'In kernel'
7296       do kkk=1,5
7297 cd        if (lprn) write (2,*) 'kkk=',kkk
7298         do lll=1,3
7299           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7300      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7301 cd          if (lprn) then
7302 cd            write (2,*) 'lll=',lll
7303 cd            write (2,*) 'iii=1'
7304 cd            do jjj=1,2
7305 cd              write (2,'(3(2f10.5),5x)')
7306 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7307 cd            enddo
7308 cd          endif
7309           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7310      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7311 cd          if (lprn) then
7312 cd            write (2,*) 'lll=',lll
7313 cd            write (2,*) 'iii=2'
7314 cd            do jjj=1,2
7315 cd              write (2,'(3(2f10.5),5x)')
7316 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7317 cd            enddo
7318 cd          endif
7319         enddo
7320       enddo
7321       return
7322       end
7323 C---------------------------------------------------------------------------
7324       double precision function eello4(i,j,k,l,jj,kk)
7325       implicit real*8 (a-h,o-z)
7326       include 'DIMENSIONS'
7327       include 'sizesclu.dat'
7328       include 'COMMON.IOUNITS'
7329       include 'COMMON.CHAIN'
7330       include 'COMMON.DERIV'
7331       include 'COMMON.INTERACT'
7332       include 'COMMON.CONTACTS'
7333       include 'COMMON.TORSION'
7334       include 'COMMON.VAR'
7335       include 'COMMON.GEO'
7336       double precision pizda(2,2),ggg1(3),ggg2(3)
7337 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7338 cd        eello4=0.0d0
7339 cd        return
7340 cd      endif
7341 cd      print *,'eello4:',i,j,k,l,jj,kk
7342 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7343 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7344 cold      eij=facont_hb(jj,i)
7345 cold      ekl=facont_hb(kk,k)
7346 cold      ekont=eij*ekl
7347       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7348       if (calc_grad) then
7349 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7350       gcorr_loc(k-1)=gcorr_loc(k-1)
7351      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7352       if (l.eq.j+1) then
7353         gcorr_loc(l-1)=gcorr_loc(l-1)
7354      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7355       else
7356         gcorr_loc(j-1)=gcorr_loc(j-1)
7357      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7358       endif
7359       do iii=1,2
7360         do kkk=1,5
7361           do lll=1,3
7362             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7363      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7364 cd            derx(lll,kkk,iii)=0.0d0
7365           enddo
7366         enddo
7367       enddo
7368 cd      gcorr_loc(l-1)=0.0d0
7369 cd      gcorr_loc(j-1)=0.0d0
7370 cd      gcorr_loc(k-1)=0.0d0
7371 cd      eel4=1.0d0
7372 cd      write (iout,*)'Contacts have occurred for peptide groups',
7373 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7374 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7375       if (j.lt.nres-1) then
7376         j1=j+1
7377         j2=j-1
7378       else
7379         j1=j-1
7380         j2=j-2
7381       endif
7382       if (l.lt.nres-1) then
7383         l1=l+1
7384         l2=l-1
7385       else
7386         l1=l-1
7387         l2=l-2
7388       endif
7389       do ll=1,3
7390 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
7391         ggg1(ll)=eel4*g_contij(ll,1)
7392         ggg2(ll)=eel4*g_contij(ll,2)
7393         ghalf=0.5d0*ggg1(ll)
7394 cd        ghalf=0.0d0
7395         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
7396         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7397         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
7398         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7399 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
7400         ghalf=0.5d0*ggg2(ll)
7401 cd        ghalf=0.0d0
7402         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
7403         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7404         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
7405         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7406       enddo
7407 cd      goto 1112
7408       do m=i+1,j-1
7409         do ll=1,3
7410 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
7411           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7412         enddo
7413       enddo
7414       do m=k+1,l-1
7415         do ll=1,3
7416 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
7417           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7418         enddo
7419       enddo
7420 1112  continue
7421       do m=i+2,j2
7422         do ll=1,3
7423           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7424         enddo
7425       enddo
7426       do m=k+2,l2
7427         do ll=1,3
7428           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7429         enddo
7430       enddo
7431 cd      do iii=1,nres-3
7432 cd        write (2,*) iii,gcorr_loc(iii)
7433 cd      enddo
7434       endif
7435       eello4=ekont*eel4
7436 cd      write (2,*) 'ekont',ekont
7437 cd      write (iout,*) 'eello4',ekont*eel4
7438       return
7439       end
7440 C---------------------------------------------------------------------------
7441       double precision function eello5(i,j,k,l,jj,kk)
7442       implicit real*8 (a-h,o-z)
7443       include 'DIMENSIONS'
7444       include 'sizesclu.dat'
7445       include 'COMMON.IOUNITS'
7446       include 'COMMON.CHAIN'
7447       include 'COMMON.DERIV'
7448       include 'COMMON.INTERACT'
7449       include 'COMMON.CONTACTS'
7450       include 'COMMON.TORSION'
7451       include 'COMMON.VAR'
7452       include 'COMMON.GEO'
7453       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7454       double precision ggg1(3),ggg2(3)
7455 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7456 C                                                                              C
7457 C                            Parallel chains                                   C
7458 C                                                                              C
7459 C          o             o                   o             o                   C
7460 C         /l\           / \             \   / \           / \   /              C
7461 C        /   \         /   \             \ /   \         /   \ /               C
7462 C       j| o |l1       | o |              o| o |         | o |o                C
7463 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7464 C      \i/   \         /   \ /             /   \         /   \                 C
7465 C       o    k1             o                                                  C
7466 C         (I)          (II)                (III)          (IV)                 C
7467 C                                                                              C
7468 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7469 C                                                                              C
7470 C                            Antiparallel chains                               C
7471 C                                                                              C
7472 C          o             o                   o             o                   C
7473 C         /j\           / \             \   / \           / \   /              C
7474 C        /   \         /   \             \ /   \         /   \ /               C
7475 C      j1| o |l        | o |              o| o |         | o |o                C
7476 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7477 C      \i/   \         /   \ /             /   \         /   \                 C
7478 C       o     k1            o                                                  C
7479 C         (I)          (II)                (III)          (IV)                 C
7480 C                                                                              C
7481 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7482 C                                                                              C
7483 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7484 C                                                                              C
7485 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7486 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7487 cd        eello5=0.0d0
7488 cd        return
7489 cd      endif
7490 cd      write (iout,*)
7491 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7492 cd     &   ' and',k,l
7493       itk=itortyp(itype(k))
7494       itl=itortyp(itype(l))
7495       itj=itortyp(itype(j))
7496       eello5_1=0.0d0
7497       eello5_2=0.0d0
7498       eello5_3=0.0d0
7499       eello5_4=0.0d0
7500 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7501 cd     &   eel5_3_num,eel5_4_num)
7502       do iii=1,2
7503         do kkk=1,5
7504           do lll=1,3
7505             derx(lll,kkk,iii)=0.0d0
7506           enddo
7507         enddo
7508       enddo
7509 cd      eij=facont_hb(jj,i)
7510 cd      ekl=facont_hb(kk,k)
7511 cd      ekont=eij*ekl
7512 cd      write (iout,*)'Contacts have occurred for peptide groups',
7513 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7514 cd      goto 1111
7515 C Contribution from the graph I.
7516 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7517 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7518       call transpose2(EUg(1,1,k),auxmat(1,1))
7519       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7520       vv(1)=pizda(1,1)-pizda(2,2)
7521       vv(2)=pizda(1,2)+pizda(2,1)
7522       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7523      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7524       if (calc_grad) then
7525 C Explicit gradient in virtual-dihedral angles.
7526       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7527      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7528      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7529       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7530       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7531       vv(1)=pizda(1,1)-pizda(2,2)
7532       vv(2)=pizda(1,2)+pizda(2,1)
7533       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7534      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7535      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7536       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7537       vv(1)=pizda(1,1)-pizda(2,2)
7538       vv(2)=pizda(1,2)+pizda(2,1)
7539       if (l.eq.j+1) then
7540         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7541      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7542      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7543       else
7544         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7545      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7546      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7547       endif
7548 C Cartesian gradient
7549       do iii=1,2
7550         do kkk=1,5
7551           do lll=1,3
7552             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7553      &        pizda(1,1))
7554             vv(1)=pizda(1,1)-pizda(2,2)
7555             vv(2)=pizda(1,2)+pizda(2,1)
7556             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7557      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7558      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7559           enddo
7560         enddo
7561       enddo
7562 c      goto 1112
7563       endif
7564 c1111  continue
7565 C Contribution from graph II
7566       call transpose2(EE(1,1,itk),auxmat(1,1))
7567       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7568       vv(1)=pizda(1,1)+pizda(2,2)
7569       vv(2)=pizda(2,1)-pizda(1,2)
7570       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7571      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7572       if (calc_grad) then
7573 C Explicit gradient in virtual-dihedral angles.
7574       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7575      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7576       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7577       vv(1)=pizda(1,1)+pizda(2,2)
7578       vv(2)=pizda(2,1)-pizda(1,2)
7579       if (l.eq.j+1) then
7580         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7581      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7582      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7583       else
7584         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7585      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7586      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7587       endif
7588 C Cartesian gradient
7589       do iii=1,2
7590         do kkk=1,5
7591           do lll=1,3
7592             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7593      &        pizda(1,1))
7594             vv(1)=pizda(1,1)+pizda(2,2)
7595             vv(2)=pizda(2,1)-pizda(1,2)
7596             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7597      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7598      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7599           enddo
7600         enddo
7601       enddo
7602 cd      goto 1112
7603       endif
7604 cd1111  continue
7605       if (l.eq.j+1) then
7606 cd        goto 1110
7607 C Parallel orientation
7608 C Contribution from graph III
7609         call transpose2(EUg(1,1,l),auxmat(1,1))
7610         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7611         vv(1)=pizda(1,1)-pizda(2,2)
7612         vv(2)=pizda(1,2)+pizda(2,1)
7613         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7614      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7615         if (calc_grad) then
7616 C Explicit gradient in virtual-dihedral angles.
7617         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7618      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7619      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7620         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7621         vv(1)=pizda(1,1)-pizda(2,2)
7622         vv(2)=pizda(1,2)+pizda(2,1)
7623         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7624      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7625      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7626         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7627         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7628         vv(1)=pizda(1,1)-pizda(2,2)
7629         vv(2)=pizda(1,2)+pizda(2,1)
7630         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7631      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7632      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7633 C Cartesian gradient
7634         do iii=1,2
7635           do kkk=1,5
7636             do lll=1,3
7637               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7638      &          pizda(1,1))
7639               vv(1)=pizda(1,1)-pizda(2,2)
7640               vv(2)=pizda(1,2)+pizda(2,1)
7641               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7642      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7643      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7644             enddo
7645           enddo
7646         enddo
7647 cd        goto 1112
7648         endif
7649 C Contribution from graph IV
7650 cd1110    continue
7651         call transpose2(EE(1,1,itl),auxmat(1,1))
7652         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7653         vv(1)=pizda(1,1)+pizda(2,2)
7654         vv(2)=pizda(2,1)-pizda(1,2)
7655         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7656      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7657         if (calc_grad) then
7658 C Explicit gradient in virtual-dihedral angles.
7659         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7660      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7661         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7662         vv(1)=pizda(1,1)+pizda(2,2)
7663         vv(2)=pizda(2,1)-pizda(1,2)
7664         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7665      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7666      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7667 C Cartesian gradient
7668         do iii=1,2
7669           do kkk=1,5
7670             do lll=1,3
7671               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7672      &          pizda(1,1))
7673               vv(1)=pizda(1,1)+pizda(2,2)
7674               vv(2)=pizda(2,1)-pizda(1,2)
7675               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7676      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7677      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7678             enddo
7679           enddo
7680         enddo
7681         endif
7682       else
7683 C Antiparallel orientation
7684 C Contribution from graph III
7685 c        goto 1110
7686         call transpose2(EUg(1,1,j),auxmat(1,1))
7687         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7688         vv(1)=pizda(1,1)-pizda(2,2)
7689         vv(2)=pizda(1,2)+pizda(2,1)
7690         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7691      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7692         if (calc_grad) then
7693 C Explicit gradient in virtual-dihedral angles.
7694         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7695      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7696      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7697         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7698         vv(1)=pizda(1,1)-pizda(2,2)
7699         vv(2)=pizda(1,2)+pizda(2,1)
7700         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7701      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7702      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7703         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7704         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7705         vv(1)=pizda(1,1)-pizda(2,2)
7706         vv(2)=pizda(1,2)+pizda(2,1)
7707         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7708      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7709      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7710 C Cartesian gradient
7711         do iii=1,2
7712           do kkk=1,5
7713             do lll=1,3
7714               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7715      &          pizda(1,1))
7716               vv(1)=pizda(1,1)-pizda(2,2)
7717               vv(2)=pizda(1,2)+pizda(2,1)
7718               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7719      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7720      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7721             enddo
7722           enddo
7723         enddo
7724 cd        goto 1112
7725         endif
7726 C Contribution from graph IV
7727 1110    continue
7728         call transpose2(EE(1,1,itj),auxmat(1,1))
7729         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7730         vv(1)=pizda(1,1)+pizda(2,2)
7731         vv(2)=pizda(2,1)-pizda(1,2)
7732         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7733      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7734         if (calc_grad) then
7735 C Explicit gradient in virtual-dihedral angles.
7736         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7737      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7738         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7739         vv(1)=pizda(1,1)+pizda(2,2)
7740         vv(2)=pizda(2,1)-pizda(1,2)
7741         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7742      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7743      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7744 C Cartesian gradient
7745         do iii=1,2
7746           do kkk=1,5
7747             do lll=1,3
7748               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7749      &          pizda(1,1))
7750               vv(1)=pizda(1,1)+pizda(2,2)
7751               vv(2)=pizda(2,1)-pizda(1,2)
7752               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7753      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7754      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7755             enddo
7756           enddo
7757         enddo
7758       endif
7759       endif
7760 1112  continue
7761       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7762 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7763 cd        write (2,*) 'ijkl',i,j,k,l
7764 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7765 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7766 cd      endif
7767 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7768 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7769 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7770 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7771       if (calc_grad) then
7772       if (j.lt.nres-1) then
7773         j1=j+1
7774         j2=j-1
7775       else
7776         j1=j-1
7777         j2=j-2
7778       endif
7779       if (l.lt.nres-1) then
7780         l1=l+1
7781         l2=l-1
7782       else
7783         l1=l-1
7784         l2=l-2
7785       endif
7786 cd      eij=1.0d0
7787 cd      ekl=1.0d0
7788 cd      ekont=1.0d0
7789 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7790       do ll=1,3
7791         ggg1(ll)=eel5*g_contij(ll,1)
7792         ggg2(ll)=eel5*g_contij(ll,2)
7793 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7794         ghalf=0.5d0*ggg1(ll)
7795 cd        ghalf=0.0d0
7796         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7797         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7798         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7799         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7800 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7801         ghalf=0.5d0*ggg2(ll)
7802 cd        ghalf=0.0d0
7803         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7804         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7805         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7806         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7807       enddo
7808 cd      goto 1112
7809       do m=i+1,j-1
7810         do ll=1,3
7811 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7812           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7813         enddo
7814       enddo
7815       do m=k+1,l-1
7816         do ll=1,3
7817 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7818           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7819         enddo
7820       enddo
7821 c1112  continue
7822       do m=i+2,j2
7823         do ll=1,3
7824           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7825         enddo
7826       enddo
7827       do m=k+2,l2
7828         do ll=1,3
7829           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7830         enddo
7831       enddo
7832 cd      do iii=1,nres-3
7833 cd        write (2,*) iii,g_corr5_loc(iii)
7834 cd      enddo
7835       endif
7836       eello5=ekont*eel5
7837 cd      write (2,*) 'ekont',ekont
7838 cd      write (iout,*) 'eello5',ekont*eel5
7839       return
7840       end
7841 c--------------------------------------------------------------------------
7842       double precision function eello6(i,j,k,l,jj,kk)
7843       implicit real*8 (a-h,o-z)
7844       include 'DIMENSIONS'
7845       include 'sizesclu.dat'
7846       include 'COMMON.IOUNITS'
7847       include 'COMMON.CHAIN'
7848       include 'COMMON.DERIV'
7849       include 'COMMON.INTERACT'
7850       include 'COMMON.CONTACTS'
7851       include 'COMMON.TORSION'
7852       include 'COMMON.VAR'
7853       include 'COMMON.GEO'
7854       include 'COMMON.FFIELD'
7855       double precision ggg1(3),ggg2(3)
7856 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7857 cd        eello6=0.0d0
7858 cd        return
7859 cd      endif
7860 cd      write (iout,*)
7861 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7862 cd     &   ' and',k,l
7863       eello6_1=0.0d0
7864       eello6_2=0.0d0
7865       eello6_3=0.0d0
7866       eello6_4=0.0d0
7867       eello6_5=0.0d0
7868       eello6_6=0.0d0
7869 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7870 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7871       do iii=1,2
7872         do kkk=1,5
7873           do lll=1,3
7874             derx(lll,kkk,iii)=0.0d0
7875           enddo
7876         enddo
7877       enddo
7878 cd      eij=facont_hb(jj,i)
7879 cd      ekl=facont_hb(kk,k)
7880 cd      ekont=eij*ekl
7881 cd      eij=1.0d0
7882 cd      ekl=1.0d0
7883 cd      ekont=1.0d0
7884       if (l.eq.j+1) then
7885         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7886         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7887         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7888         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7889         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7890         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7891       else
7892         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7893         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7894         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7895         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7896         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7897           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7898         else
7899           eello6_5=0.0d0
7900         endif
7901         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7902       endif
7903 C If turn contributions are considered, they will be handled separately.
7904       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7905 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7906 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7907 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7908 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7909 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7910 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7911 cd      goto 1112
7912       if (calc_grad) then
7913       if (j.lt.nres-1) then
7914         j1=j+1
7915         j2=j-1
7916       else
7917         j1=j-1
7918         j2=j-2
7919       endif
7920       if (l.lt.nres-1) then
7921         l1=l+1
7922         l2=l-1
7923       else
7924         l1=l-1
7925         l2=l-2
7926       endif
7927       do ll=1,3
7928         ggg1(ll)=eel6*g_contij(ll,1)
7929         ggg2(ll)=eel6*g_contij(ll,2)
7930 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7931         ghalf=0.5d0*ggg1(ll)
7932 cd        ghalf=0.0d0
7933         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7934         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7935         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7936         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7937         ghalf=0.5d0*ggg2(ll)
7938 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7939 cd        ghalf=0.0d0
7940         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7941         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7942         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7943         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7944       enddo
7945 cd      goto 1112
7946       do m=i+1,j-1
7947         do ll=1,3
7948 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7949           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7950         enddo
7951       enddo
7952       do m=k+1,l-1
7953         do ll=1,3
7954 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7955           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7956         enddo
7957       enddo
7958 1112  continue
7959       do m=i+2,j2
7960         do ll=1,3
7961           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7962         enddo
7963       enddo
7964       do m=k+2,l2
7965         do ll=1,3
7966           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7967         enddo
7968       enddo
7969 cd      do iii=1,nres-3
7970 cd        write (2,*) iii,g_corr6_loc(iii)
7971 cd      enddo
7972       endif
7973       eello6=ekont*eel6
7974 cd      write (2,*) 'ekont',ekont
7975 cd      write (iout,*) 'eello6',ekont*eel6
7976       return
7977       end
7978 c--------------------------------------------------------------------------
7979       double precision function eello6_graph1(i,j,k,l,imat,swap)
7980       implicit real*8 (a-h,o-z)
7981       include 'DIMENSIONS'
7982       include 'sizesclu.dat'
7983       include 'COMMON.IOUNITS'
7984       include 'COMMON.CHAIN'
7985       include 'COMMON.DERIV'
7986       include 'COMMON.INTERACT'
7987       include 'COMMON.CONTACTS'
7988       include 'COMMON.TORSION'
7989       include 'COMMON.VAR'
7990       include 'COMMON.GEO'
7991       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7992       logical swap
7993       logical lprn
7994       common /kutas/ lprn
7995 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7996 C                                                                              C
7997 C      Parallel       Antiparallel                                             C
7998 C                                                                              C
7999 C          o             o                                                     C
8000 C         /l\           /j\                                                    C
8001 C        /   \         /   \                                                   C
8002 C       /| o |         | o |\                                                  C
8003 C     \ j|/k\|  /   \  |/k\|l /                                                C
8004 C      \ /   \ /     \ /   \ /                                                 C
8005 C       o     o       o     o                                                  C
8006 C       i             i                                                        C
8007 C                                                                              C
8008 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8009       itk=itortyp(itype(k))
8010       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8011       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8012       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8013       call transpose2(EUgC(1,1,k),auxmat(1,1))
8014       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8015       vv1(1)=pizda1(1,1)-pizda1(2,2)
8016       vv1(2)=pizda1(1,2)+pizda1(2,1)
8017       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8018       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8019       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8020       s5=scalar2(vv(1),Dtobr2(1,i))
8021 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8022       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8023       if (.not. calc_grad) return
8024       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8025      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8026      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8027      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8028      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8029      & +scalar2(vv(1),Dtobr2der(1,i)))
8030       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8031       vv1(1)=pizda1(1,1)-pizda1(2,2)
8032       vv1(2)=pizda1(1,2)+pizda1(2,1)
8033       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8034       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8035       if (l.eq.j+1) then
8036         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8037      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8038      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8039      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8040      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8041       else
8042         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8043      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8044      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8045      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8046      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8047       endif
8048       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8049       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8050       vv1(1)=pizda1(1,1)-pizda1(2,2)
8051       vv1(2)=pizda1(1,2)+pizda1(2,1)
8052       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8053      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8054      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8055      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8056       do iii=1,2
8057         if (swap) then
8058           ind=3-iii
8059         else
8060           ind=iii
8061         endif
8062         do kkk=1,5
8063           do lll=1,3
8064             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8065             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8066             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8067             call transpose2(EUgC(1,1,k),auxmat(1,1))
8068             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8069      &        pizda1(1,1))
8070             vv1(1)=pizda1(1,1)-pizda1(2,2)
8071             vv1(2)=pizda1(1,2)+pizda1(2,1)
8072             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8073             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8074      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8075             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8076      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8077             s5=scalar2(vv(1),Dtobr2(1,i))
8078             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8079           enddo
8080         enddo
8081       enddo
8082       return
8083       end
8084 c----------------------------------------------------------------------------
8085       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8086       implicit real*8 (a-h,o-z)
8087       include 'DIMENSIONS'
8088       include 'sizesclu.dat'
8089       include 'COMMON.IOUNITS'
8090       include 'COMMON.CHAIN'
8091       include 'COMMON.DERIV'
8092       include 'COMMON.INTERACT'
8093       include 'COMMON.CONTACTS'
8094       include 'COMMON.TORSION'
8095       include 'COMMON.VAR'
8096       include 'COMMON.GEO'
8097       logical swap
8098       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8099      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8100       logical lprn
8101       common /kutas/ lprn
8102 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8103 C                                                                              C
8104 C      Parallel       Antiparallel                                             C
8105 C                                                                              C
8106 C          o             o                                                     C
8107 C     \   /l\           /j\   /                                                C
8108 C      \ /   \         /   \ /                                                 C
8109 C       o| o |         | o |o                                                  C
8110 C     \ j|/k\|      \  |/k\|l                                                  C
8111 C      \ /   \       \ /   \                                                   C
8112 C       o             o                                                        C
8113 C       i             i                                                        C
8114 C                                                                              C
8115 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8116 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8117 C AL 7/4/01 s1 would occur in the sixth-order moment,
8118 C           but not in a cluster cumulant
8119 #ifdef MOMENT
8120       s1=dip(1,jj,i)*dip(1,kk,k)
8121 #endif
8122       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8123       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8124       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8125       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8126       call transpose2(EUg(1,1,k),auxmat(1,1))
8127       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8128       vv(1)=pizda(1,1)-pizda(2,2)
8129       vv(2)=pizda(1,2)+pizda(2,1)
8130       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8131 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8132 #ifdef MOMENT
8133       eello6_graph2=-(s1+s2+s3+s4)
8134 #else
8135       eello6_graph2=-(s2+s3+s4)
8136 #endif
8137 c      eello6_graph2=-s3
8138       if (.not. calc_grad) return
8139 C Derivatives in gamma(i-1)
8140       if (i.gt.1) then
8141 #ifdef MOMENT
8142         s1=dipderg(1,jj,i)*dip(1,kk,k)
8143 #endif
8144         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8145         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8146         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8147         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8148 #ifdef MOMENT
8149         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8150 #else
8151         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8152 #endif
8153 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8154       endif
8155 C Derivatives in gamma(k-1)
8156 #ifdef MOMENT
8157       s1=dip(1,jj,i)*dipderg(1,kk,k)
8158 #endif
8159       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8160       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8161       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8162       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8163       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8164       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8165       vv(1)=pizda(1,1)-pizda(2,2)
8166       vv(2)=pizda(1,2)+pizda(2,1)
8167       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8168 #ifdef MOMENT
8169       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8170 #else
8171       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8172 #endif
8173 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8174 C Derivatives in gamma(j-1) or gamma(l-1)
8175       if (j.gt.1) then
8176 #ifdef MOMENT
8177         s1=dipderg(3,jj,i)*dip(1,kk,k)
8178 #endif
8179         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8180         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8181         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8182         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8183         vv(1)=pizda(1,1)-pizda(2,2)
8184         vv(2)=pizda(1,2)+pizda(2,1)
8185         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8186 #ifdef MOMENT
8187         if (swap) then
8188           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8189         else
8190           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8191         endif
8192 #endif
8193         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8194 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8195       endif
8196 C Derivatives in gamma(l-1) or gamma(j-1)
8197       if (l.gt.1) then
8198 #ifdef MOMENT
8199         s1=dip(1,jj,i)*dipderg(3,kk,k)
8200 #endif
8201         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8202         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8203         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8204         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8205         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8206         vv(1)=pizda(1,1)-pizda(2,2)
8207         vv(2)=pizda(1,2)+pizda(2,1)
8208         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8209 #ifdef MOMENT
8210         if (swap) then
8211           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8212         else
8213           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8214         endif
8215 #endif
8216         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8217 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8218       endif
8219 C Cartesian derivatives.
8220       if (lprn) then
8221         write (2,*) 'In eello6_graph2'
8222         do iii=1,2
8223           write (2,*) 'iii=',iii
8224           do kkk=1,5
8225             write (2,*) 'kkk=',kkk
8226             do jjj=1,2
8227               write (2,'(3(2f10.5),5x)')
8228      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8229             enddo
8230           enddo
8231         enddo
8232       endif
8233       do iii=1,2
8234         do kkk=1,5
8235           do lll=1,3
8236 #ifdef MOMENT
8237             if (iii.eq.1) then
8238               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8239             else
8240               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8241             endif
8242 #endif
8243             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8244      &        auxvec(1))
8245             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8246             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8247      &        auxvec(1))
8248             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8249             call transpose2(EUg(1,1,k),auxmat(1,1))
8250             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8251      &        pizda(1,1))
8252             vv(1)=pizda(1,1)-pizda(2,2)
8253             vv(2)=pizda(1,2)+pizda(2,1)
8254             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8255 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8256 #ifdef MOMENT
8257             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8258 #else
8259             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8260 #endif
8261             if (swap) then
8262               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8263             else
8264               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8265             endif
8266           enddo
8267         enddo
8268       enddo
8269       return
8270       end
8271 c----------------------------------------------------------------------------
8272       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8273       implicit real*8 (a-h,o-z)
8274       include 'DIMENSIONS'
8275       include 'sizesclu.dat'
8276       include 'COMMON.IOUNITS'
8277       include 'COMMON.CHAIN'
8278       include 'COMMON.DERIV'
8279       include 'COMMON.INTERACT'
8280       include 'COMMON.CONTACTS'
8281       include 'COMMON.TORSION'
8282       include 'COMMON.VAR'
8283       include 'COMMON.GEO'
8284       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8285       logical swap
8286 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8287 C                                                                              C
8288 C      Parallel       Antiparallel                                             C
8289 C                                                                              C
8290 C          o             o                                                     C
8291 C         /l\   /   \   /j\                                                    C
8292 C        /   \ /     \ /   \                                                   C
8293 C       /| o |o       o| o |\                                                  C
8294 C       j|/k\|  /      |/k\|l /                                                C
8295 C        /   \ /       /   \ /                                                 C
8296 C       /     o       /     o                                                  C
8297 C       i             i                                                        C
8298 C                                                                              C
8299 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8300 C
8301 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8302 C           energy moment and not to the cluster cumulant.
8303       iti=itortyp(itype(i))
8304       if (j.lt.nres-1) then
8305         itj1=itortyp(itype(j+1))
8306       else
8307         itj1=ntortyp+1
8308       endif
8309       itk=itortyp(itype(k))
8310       itk1=itortyp(itype(k+1))
8311       if (l.lt.nres-1) then
8312         itl1=itortyp(itype(l+1))
8313       else
8314         itl1=ntortyp+1
8315       endif
8316 #ifdef MOMENT
8317       s1=dip(4,jj,i)*dip(4,kk,k)
8318 #endif
8319       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8320       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8321       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8322       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8323       call transpose2(EE(1,1,itk),auxmat(1,1))
8324       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8325       vv(1)=pizda(1,1)+pizda(2,2)
8326       vv(2)=pizda(2,1)-pizda(1,2)
8327       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8328 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8329 #ifdef MOMENT
8330       eello6_graph3=-(s1+s2+s3+s4)
8331 #else
8332       eello6_graph3=-(s2+s3+s4)
8333 #endif
8334 c      eello6_graph3=-s4
8335       if (.not. calc_grad) return
8336 C Derivatives in gamma(k-1)
8337       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8338       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8339       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8340       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8341 C Derivatives in gamma(l-1)
8342       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8343       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8344       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8345       vv(1)=pizda(1,1)+pizda(2,2)
8346       vv(2)=pizda(2,1)-pizda(1,2)
8347       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8348       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8349 C Cartesian derivatives.
8350       do iii=1,2
8351         do kkk=1,5
8352           do lll=1,3
8353 #ifdef MOMENT
8354             if (iii.eq.1) then
8355               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8356             else
8357               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8358             endif
8359 #endif
8360             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8361      &        auxvec(1))
8362             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8363             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8364      &        auxvec(1))
8365             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8366             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8367      &        pizda(1,1))
8368             vv(1)=pizda(1,1)+pizda(2,2)
8369             vv(2)=pizda(2,1)-pizda(1,2)
8370             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8371 #ifdef MOMENT
8372             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8373 #else
8374             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8375 #endif
8376             if (swap) then
8377               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8378             else
8379               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8380             endif
8381 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8382           enddo
8383         enddo
8384       enddo
8385       return
8386       end
8387 c----------------------------------------------------------------------------
8388       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8389       implicit real*8 (a-h,o-z)
8390       include 'DIMENSIONS'
8391       include 'sizesclu.dat'
8392       include 'COMMON.IOUNITS'
8393       include 'COMMON.CHAIN'
8394       include 'COMMON.DERIV'
8395       include 'COMMON.INTERACT'
8396       include 'COMMON.CONTACTS'
8397       include 'COMMON.TORSION'
8398       include 'COMMON.VAR'
8399       include 'COMMON.GEO'
8400       include 'COMMON.FFIELD'
8401       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8402      & auxvec1(2),auxmat1(2,2)
8403       logical swap
8404 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8405 C                                                                              C
8406 C      Parallel       Antiparallel                                             C
8407 C                                                                              C
8408 C          o             o                                                     C
8409 C         /l\   /   \   /j\                                                    C
8410 C        /   \ /     \ /   \                                                   C
8411 C       /| o |o       o| o |\                                                  C
8412 C     \ j|/k\|      \  |/k\|l                                                  C
8413 C      \ /   \       \ /   \                                                   C
8414 C       o     \       o     \                                                  C
8415 C       i             i                                                        C
8416 C                                                                              C
8417 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8418 C
8419 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8420 C           energy moment and not to the cluster cumulant.
8421 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8422       iti=itortyp(itype(i))
8423       itj=itortyp(itype(j))
8424       if (j.lt.nres-1) then
8425         itj1=itortyp(itype(j+1))
8426       else
8427         itj1=ntortyp+1
8428       endif
8429       itk=itortyp(itype(k))
8430       if (k.lt.nres-1) then
8431         itk1=itortyp(itype(k+1))
8432       else
8433         itk1=ntortyp+1
8434       endif
8435       itl=itortyp(itype(l))
8436       if (l.lt.nres-1) then
8437         itl1=itortyp(itype(l+1))
8438       else
8439         itl1=ntortyp+1
8440       endif
8441 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8442 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8443 cd     & ' itl',itl,' itl1',itl1
8444 #ifdef MOMENT
8445       if (imat.eq.1) then
8446         s1=dip(3,jj,i)*dip(3,kk,k)
8447       else
8448         s1=dip(2,jj,j)*dip(2,kk,l)
8449       endif
8450 #endif
8451       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8452       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8453       if (j.eq.l+1) then
8454         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8455         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8456       else
8457         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8458         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8459       endif
8460       call transpose2(EUg(1,1,k),auxmat(1,1))
8461       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8462       vv(1)=pizda(1,1)-pizda(2,2)
8463       vv(2)=pizda(2,1)+pizda(1,2)
8464       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8465 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8466 #ifdef MOMENT
8467       eello6_graph4=-(s1+s2+s3+s4)
8468 #else
8469       eello6_graph4=-(s2+s3+s4)
8470 #endif
8471       if (.not. calc_grad) return
8472 C Derivatives in gamma(i-1)
8473       if (i.gt.1) then
8474 #ifdef MOMENT
8475         if (imat.eq.1) then
8476           s1=dipderg(2,jj,i)*dip(3,kk,k)
8477         else
8478           s1=dipderg(4,jj,j)*dip(2,kk,l)
8479         endif
8480 #endif
8481         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8482         if (j.eq.l+1) then
8483           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8484           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8485         else
8486           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8487           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8488         endif
8489         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8490         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8491 cd          write (2,*) 'turn6 derivatives'
8492 #ifdef MOMENT
8493           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8494 #else
8495           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8496 #endif
8497         else
8498 #ifdef MOMENT
8499           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8500 #else
8501           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8502 #endif
8503         endif
8504       endif
8505 C Derivatives in gamma(k-1)
8506 #ifdef MOMENT
8507       if (imat.eq.1) then
8508         s1=dip(3,jj,i)*dipderg(2,kk,k)
8509       else
8510         s1=dip(2,jj,j)*dipderg(4,kk,l)
8511       endif
8512 #endif
8513       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8514       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8515       if (j.eq.l+1) then
8516         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8517         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8518       else
8519         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8520         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8521       endif
8522       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8523       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8524       vv(1)=pizda(1,1)-pizda(2,2)
8525       vv(2)=pizda(2,1)+pizda(1,2)
8526       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8527       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8528 #ifdef MOMENT
8529         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8530 #else
8531         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8532 #endif
8533       else
8534 #ifdef MOMENT
8535         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8536 #else
8537         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8538 #endif
8539       endif
8540 C Derivatives in gamma(j-1) or gamma(l-1)
8541       if (l.eq.j+1 .and. l.gt.1) then
8542         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8543         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8544         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8545         vv(1)=pizda(1,1)-pizda(2,2)
8546         vv(2)=pizda(2,1)+pizda(1,2)
8547         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8548         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8549       else if (j.gt.1) then
8550         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8551         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8552         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8553         vv(1)=pizda(1,1)-pizda(2,2)
8554         vv(2)=pizda(2,1)+pizda(1,2)
8555         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8556         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8557           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8558         else
8559           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8560         endif
8561       endif
8562 C Cartesian derivatives.
8563       do iii=1,2
8564         do kkk=1,5
8565           do lll=1,3
8566 #ifdef MOMENT
8567             if (iii.eq.1) then
8568               if (imat.eq.1) then
8569                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8570               else
8571                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8572               endif
8573             else
8574               if (imat.eq.1) then
8575                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8576               else
8577                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8578               endif
8579             endif
8580 #endif
8581             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8582      &        auxvec(1))
8583             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8584             if (j.eq.l+1) then
8585               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8586      &          b1(1,itj1),auxvec(1))
8587               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8588             else
8589               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8590      &          b1(1,itl1),auxvec(1))
8591               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8592             endif
8593             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8594      &        pizda(1,1))
8595             vv(1)=pizda(1,1)-pizda(2,2)
8596             vv(2)=pizda(2,1)+pizda(1,2)
8597             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8598             if (swap) then
8599               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8600 #ifdef MOMENT
8601                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8602      &             -(s1+s2+s4)
8603 #else
8604                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8605      &             -(s2+s4)
8606 #endif
8607                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8608               else
8609 #ifdef MOMENT
8610                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8611 #else
8612                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8613 #endif
8614                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8615               endif
8616             else
8617 #ifdef MOMENT
8618               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8619 #else
8620               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8621 #endif
8622               if (l.eq.j+1) then
8623                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8624               else
8625                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8626               endif
8627             endif
8628           enddo
8629         enddo
8630       enddo
8631       return
8632       end
8633 c----------------------------------------------------------------------------
8634       double precision function eello_turn6(i,jj,kk)
8635       implicit real*8 (a-h,o-z)
8636       include 'DIMENSIONS'
8637       include 'sizesclu.dat'
8638       include 'COMMON.IOUNITS'
8639       include 'COMMON.CHAIN'
8640       include 'COMMON.DERIV'
8641       include 'COMMON.INTERACT'
8642       include 'COMMON.CONTACTS'
8643       include 'COMMON.TORSION'
8644       include 'COMMON.VAR'
8645       include 'COMMON.GEO'
8646       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8647      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8648      &  ggg1(3),ggg2(3)
8649       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8650      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8651 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8652 C           the respective energy moment and not to the cluster cumulant.
8653       eello_turn6=0.0d0
8654       j=i+4
8655       k=i+1
8656       l=i+3
8657       iti=itortyp(itype(i))
8658       itk=itortyp(itype(k))
8659       itk1=itortyp(itype(k+1))
8660       itl=itortyp(itype(l))
8661       itj=itortyp(itype(j))
8662 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8663 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8664 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8665 cd        eello6=0.0d0
8666 cd        return
8667 cd      endif
8668 cd      write (iout,*)
8669 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8670 cd     &   ' and',k,l
8671 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8672       do iii=1,2
8673         do kkk=1,5
8674           do lll=1,3
8675             derx_turn(lll,kkk,iii)=0.0d0
8676           enddo
8677         enddo
8678       enddo
8679 cd      eij=1.0d0
8680 cd      ekl=1.0d0
8681 cd      ekont=1.0d0
8682       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8683 cd      eello6_5=0.0d0
8684 cd      write (2,*) 'eello6_5',eello6_5
8685 #ifdef MOMENT
8686       call transpose2(AEA(1,1,1),auxmat(1,1))
8687       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8688       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8689       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8690 #else
8691       s1 = 0.0d0
8692 #endif
8693       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8694       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8695       s2 = scalar2(b1(1,itk),vtemp1(1))
8696 #ifdef MOMENT
8697       call transpose2(AEA(1,1,2),atemp(1,1))
8698       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8699       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8700       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8701 #else
8702       s8=0.0d0
8703 #endif
8704       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8705       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8706       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8707 #ifdef MOMENT
8708       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8709       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8710       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8711       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8712       ss13 = scalar2(b1(1,itk),vtemp4(1))
8713       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8714 #else
8715       s13=0.0d0
8716 #endif
8717 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8718 c      s1=0.0d0
8719 c      s2=0.0d0
8720 c      s8=0.0d0
8721 c      s12=0.0d0
8722 c      s13=0.0d0
8723       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8724       if (calc_grad) then
8725 C Derivatives in gamma(i+2)
8726 #ifdef MOMENT
8727       call transpose2(AEA(1,1,1),auxmatd(1,1))
8728       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8729       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8730       call transpose2(AEAderg(1,1,2),atempd(1,1))
8731       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8732       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8733 #else
8734       s8d=0.0d0
8735 #endif
8736       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8737       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8738       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8739 c      s1d=0.0d0
8740 c      s2d=0.0d0
8741 c      s8d=0.0d0
8742 c      s12d=0.0d0
8743 c      s13d=0.0d0
8744       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8745 C Derivatives in gamma(i+3)
8746 #ifdef MOMENT
8747       call transpose2(AEA(1,1,1),auxmatd(1,1))
8748       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8749       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8750       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8751 #else
8752       s1d=0.0d0
8753 #endif
8754       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8755       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8756       s2d = scalar2(b1(1,itk),vtemp1d(1))
8757 #ifdef MOMENT
8758       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8759       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8760 #endif
8761       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8762 #ifdef MOMENT
8763       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8764       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8765       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8766 #else
8767       s13d=0.0d0
8768 #endif
8769 c      s1d=0.0d0
8770 c      s2d=0.0d0
8771 c      s8d=0.0d0
8772 c      s12d=0.0d0
8773 c      s13d=0.0d0
8774 #ifdef MOMENT
8775       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8776      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8777 #else
8778       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8779      &               -0.5d0*ekont*(s2d+s12d)
8780 #endif
8781 C Derivatives in gamma(i+4)
8782       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8783       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8784       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8785 #ifdef MOMENT
8786       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8787       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8788       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8789 #else
8790       s13d = 0.0d0
8791 #endif
8792 c      s1d=0.0d0
8793 c      s2d=0.0d0
8794 c      s8d=0.0d0
8795 C      s12d=0.0d0
8796 c      s13d=0.0d0
8797 #ifdef MOMENT
8798       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8799 #else
8800       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8801 #endif
8802 C Derivatives in gamma(i+5)
8803 #ifdef MOMENT
8804       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8805       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8806       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8807 #else
8808       s1d = 0.0d0
8809 #endif
8810       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8811       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8812       s2d = scalar2(b1(1,itk),vtemp1d(1))
8813 #ifdef MOMENT
8814       call transpose2(AEA(1,1,2),atempd(1,1))
8815       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8816       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8817 #else
8818       s8d = 0.0d0
8819 #endif
8820       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8821       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8822 #ifdef MOMENT
8823       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8824       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8825       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8826 #else
8827       s13d = 0.0d0
8828 #endif
8829 c      s1d=0.0d0
8830 c      s2d=0.0d0
8831 c      s8d=0.0d0
8832 c      s12d=0.0d0
8833 c      s13d=0.0d0
8834 #ifdef MOMENT
8835       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8836      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8837 #else
8838       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8839      &               -0.5d0*ekont*(s2d+s12d)
8840 #endif
8841 C Cartesian derivatives
8842       do iii=1,2
8843         do kkk=1,5
8844           do lll=1,3
8845 #ifdef MOMENT
8846             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8847             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8848             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8849 #else
8850             s1d = 0.0d0
8851 #endif
8852             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8853             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8854      &          vtemp1d(1))
8855             s2d = scalar2(b1(1,itk),vtemp1d(1))
8856 #ifdef MOMENT
8857             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8858             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8859             s8d = -(atempd(1,1)+atempd(2,2))*
8860      &           scalar2(cc(1,1,itl),vtemp2(1))
8861 #else
8862             s8d = 0.0d0
8863 #endif
8864             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8865      &           auxmatd(1,1))
8866             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8867             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8868 c      s1d=0.0d0
8869 c      s2d=0.0d0
8870 c      s8d=0.0d0
8871 c      s12d=0.0d0
8872 c      s13d=0.0d0
8873 #ifdef MOMENT
8874             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8875      &        - 0.5d0*(s1d+s2d)
8876 #else
8877             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8878      &        - 0.5d0*s2d
8879 #endif
8880 #ifdef MOMENT
8881             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8882      &        - 0.5d0*(s8d+s12d)
8883 #else
8884             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8885      &        - 0.5d0*s12d
8886 #endif
8887           enddo
8888         enddo
8889       enddo
8890 #ifdef MOMENT
8891       do kkk=1,5
8892         do lll=1,3
8893           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8894      &      achuj_tempd(1,1))
8895           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8896           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8897           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8898           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8899           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8900      &      vtemp4d(1))
8901           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8902           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8903           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8904         enddo
8905       enddo
8906 #endif
8907 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8908 cd     &  16*eel_turn6_num
8909 cd      goto 1112
8910       if (j.lt.nres-1) then
8911         j1=j+1
8912         j2=j-1
8913       else
8914         j1=j-1
8915         j2=j-2
8916       endif
8917       if (l.lt.nres-1) then
8918         l1=l+1
8919         l2=l-1
8920       else
8921         l1=l-1
8922         l2=l-2
8923       endif
8924       do ll=1,3
8925         ggg1(ll)=eel_turn6*g_contij(ll,1)
8926         ggg2(ll)=eel_turn6*g_contij(ll,2)
8927         ghalf=0.5d0*ggg1(ll)
8928 cd        ghalf=0.0d0
8929         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8930      &    +ekont*derx_turn(ll,2,1)
8931         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8932         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8933      &    +ekont*derx_turn(ll,4,1)
8934         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8935         ghalf=0.5d0*ggg2(ll)
8936 cd        ghalf=0.0d0
8937         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8938      &    +ekont*derx_turn(ll,2,2)
8939         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8940         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8941      &    +ekont*derx_turn(ll,4,2)
8942         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8943       enddo
8944 cd      goto 1112
8945       do m=i+1,j-1
8946         do ll=1,3
8947           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8948         enddo
8949       enddo
8950       do m=k+1,l-1
8951         do ll=1,3
8952           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8953         enddo
8954       enddo
8955 1112  continue
8956       do m=i+2,j2
8957         do ll=1,3
8958           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8959         enddo
8960       enddo
8961       do m=k+2,l2
8962         do ll=1,3
8963           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8964         enddo
8965       enddo
8966 cd      do iii=1,nres-3
8967 cd        write (2,*) iii,g_corr6_loc(iii)
8968 cd      enddo
8969       endif
8970       eello_turn6=ekont*eel_turn6
8971 cd      write (2,*) 'ekont',ekont
8972 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8973       return
8974       end
8975 crc-------------------------------------------------
8976       SUBROUTINE MATVEC2(A1,V1,V2)
8977       implicit real*8 (a-h,o-z)
8978       include 'DIMENSIONS'
8979       DIMENSION A1(2,2),V1(2),V2(2)
8980 c      DO 1 I=1,2
8981 c        VI=0.0
8982 c        DO 3 K=1,2
8983 c    3     VI=VI+A1(I,K)*V1(K)
8984 c        Vaux(I)=VI
8985 c    1 CONTINUE
8986
8987       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8988       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8989
8990       v2(1)=vaux1
8991       v2(2)=vaux2
8992       END
8993 C---------------------------------------
8994       SUBROUTINE MATMAT2(A1,A2,A3)
8995       implicit real*8 (a-h,o-z)
8996       include 'DIMENSIONS'
8997       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8998 c      DIMENSION AI3(2,2)
8999 c        DO  J=1,2
9000 c          A3IJ=0.0
9001 c          DO K=1,2
9002 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9003 c          enddo
9004 c          A3(I,J)=A3IJ
9005 c       enddo
9006 c      enddo
9007
9008       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9009       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9010       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9011       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9012
9013       A3(1,1)=AI3_11
9014       A3(2,1)=AI3_21
9015       A3(1,2)=AI3_12
9016       A3(2,2)=AI3_22
9017       END
9018
9019 c-------------------------------------------------------------------------
9020       double precision function scalar2(u,v)
9021       implicit none
9022       double precision u(2),v(2)
9023       double precision sc
9024       integer i
9025       scalar2=u(1)*v(1)+u(2)*v(2)
9026       return
9027       end
9028
9029 C-----------------------------------------------------------------------------
9030
9031       subroutine transpose2(a,at)
9032       implicit none
9033       double precision a(2,2),at(2,2)
9034       at(1,1)=a(1,1)
9035       at(1,2)=a(2,1)
9036       at(2,1)=a(1,2)
9037       at(2,2)=a(2,2)
9038       return
9039       end
9040 c--------------------------------------------------------------------------
9041       subroutine transpose(n,a,at)
9042       implicit none
9043       integer n,i,j
9044       double precision a(n,n),at(n,n)
9045       do i=1,n
9046         do j=1,n
9047           at(j,i)=a(i,j)
9048         enddo
9049       enddo
9050       return
9051       end
9052 C---------------------------------------------------------------------------
9053       subroutine prodmat3(a1,a2,kk,transp,prod)
9054       implicit none
9055       integer i,j
9056       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9057       logical transp
9058 crc      double precision auxmat(2,2),prod_(2,2)
9059
9060       if (transp) then
9061 crc        call transpose2(kk(1,1),auxmat(1,1))
9062 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9063 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9064
9065            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9066      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9067            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9068      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9069            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9070      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9071            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9072      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9073
9074       else
9075 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9076 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9077
9078            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9079      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9080            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9081      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9082            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9083      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9084            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9085      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9086
9087       endif
9088 c      call transpose2(a2(1,1),a2t(1,1))
9089
9090 crc      print *,transp
9091 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9092 crc      print *,((prod(i,j),i=1,2),j=1,2)
9093
9094       return
9095       end
9096 C-----------------------------------------------------------------------------
9097       double precision function scalar(u,v)
9098       implicit none
9099       double precision u(3),v(3)
9100       double precision sc
9101       integer i
9102       sc=0.0d0
9103       do i=1,3
9104         sc=sc+u(i)*v(i)
9105       enddo
9106       scalar=sc
9107       return
9108       end
9109