source/cluster/wham/src-M/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 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15 #ifdef MPL
  16       include 'COMMON.INFO'
  17       external d_vadd
  18       integer ready
  19 #endif
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       double precision fact(6)
  26 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       goto (101,102,103,104,105) ipot
  32 C Lennard-Jones potential.
  33   101 call elj(evdw,evdw_t)
  34 cd    print '(a)','Exit ELJ'
  35       goto 106
  36 C Lennard-Jones-Kihara potential (shifted).
  37   102 call eljk(evdw,evdw_t)
  38       goto 106
  39 C Berne-Pechukas potential (dilated LJ, angular dependence).
  40   103 call ebp(evdw,evdw_t)
  41       goto 106
  42 C Gay-Berne potential (shifted LJ, angular dependence).
  43   104 call egb(evdw,evdw_t)
  44       goto 106
  45 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  46   105 call egbv(evdw,evdw_t)
  47 C
  48 C Calculate electrostatic (H-bonding) energy of the main chain.
  49 C
  50   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  51 C
  52 C Calculate excluded-volume interaction energy between peptide groups
  53 C and side chains.
  54 C
  55       call escp(evdw2,evdw2_14)
  56 c
  57 c Calculate the bond-stretching energy
  58 c
  59       call ebond(estr)
  60 c      write (iout,*) "estr",estr
  61 C
  62 C Calculate the disulfide-bridge and other energy and the contributions
  63 C from other distance constraints.
  64 cd    print *,'Calling EHPB'
  65       call edis(ehpb)
  66 cd    print *,'EHPB exitted succesfully.'
  67 C
  68 C Calculate the virtual-bond-angle energy.
  69 C
  70       call ebend(ebe)
  71 cd    print *,'Bend energy finished.'
  72 C
  73 C Calculate the SC local energy.
  74 C
  75       call esc(escloc)
  76 cd    print *,'SCLOC energy finished.'
  77 C
  78 C Calculate the virtual-bond torsional energy.
  79 C
  80 cd    print *,'nterm=',nterm
  81       call etor(etors,edihcnstr,fact(1))
  82 C
  83 C 6/23/01 Calculate double-torsional energy
  84 C
  85       call etor_d(etors_d,fact(2))
  86 C
  87 C 21/5/07 Calculate local sicdechain correlation energy
  88 C
  89       call eback_sc_corr(esccor)
  90 C
  91 C 12/1/95 Multi-body terms
  92 C
  93       n_corr=0
  94       n_corr1=0
  95       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  96      &    .or. wturn6.gt.0.0d0) then
  97 c         print *,"calling multibody_eello"
  98          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
  99 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 100 c         print *,ecorr,ecorr5,ecorr6,eturn6
 101       endif
 102       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 103          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 104       endif
 105 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 106 #ifdef SPLITELE
 107       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 108      & +wvdwpp*evdw1
 109      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 110      & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 111      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 112      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 113      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 114      & +wbond*estr+wsccor*fact(1)*esccor
 115 #else
 116       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 117      & +welec*fact(1)*(ees+evdw1)
 118      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 119      & +wstrain*ehpb+nss*ebr+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 120      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 121      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 122      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 123      & +wbond*estr+wsccor*fact(1)*esccor
 124 #endif
 125       energia(0)=etot
 126       energia(1)=evdw
 127 c      call enerprint(energia(0),frac)
 128 #ifdef SCP14
 129       energia(2)=evdw2-evdw2_14
 130       energia(17)=evdw2_14
 131 #else
 132       energia(2)=evdw2
 133       energia(17)=0.0d0
 134 #endif
 135 #ifdef SPLITELE
 136       energia(3)=ees
 137       energia(16)=evdw1
 138 #else
 139       energia(3)=ees+evdw1
 140       energia(16)=0.0d0
 141 #endif
 142       energia(4)=ecorr
 143       energia(5)=ecorr5
 144       energia(6)=ecorr6
 145       energia(7)=eel_loc
 146       energia(8)=eello_turn3
 147       energia(9)=eello_turn4
 148       energia(10)=eturn6
 149       energia(11)=ebe
 150       energia(12)=escloc
 151       energia(13)=etors
 152       energia(14)=etors_d
 153       energia(15)=ehpb
 154       energia(18)=estr
 155       energia(19)=esccor
 156       energia(20)=edihcnstr
 157       energia(21)=evdw_t
 158 c detecting NaNQ
 159 #ifdef ISNAN
 160 #ifdef AIX
 161       if (isnan(etot).ne.0) energia(0)=1.0d+99
 162 #else
 163       if (isnan(etot)) energia(0)=1.0d+99
 164 #endif
 165 #else
 166       i=0
 167 #ifdef WINPGI
 168       idumm=proc_proc(etot,i)
 169 #else
 170       call proc_proc(etot,i)
 171 #endif
 172       if(i.eq.1)energia(0)=1.0d+99
 173 #endif
 174 #ifdef MPL
 175 c     endif
 176 #endif
 177       if (calc_grad) then
 178 C
 179 C Sum up the components of the Cartesian gradient.
 180 C
 181 #ifdef SPLITELE
 182       do i=1,nct
 183         do j=1,3
 184           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 185      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 186      &                wbond*gradb(j,i)+
 187      &                wstrain*ghpbc(j,i)+
 188      &                wcorr*fact(3)*gradcorr(j,i)+
 189      &                wel_loc*fact(2)*gel_loc(j,i)+
 190      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 191      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 192      &                wcorr5*fact(4)*gradcorr5(j,i)+
 193      &                wcorr6*fact(5)*gradcorr6(j,i)+
 194      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 195      &                wsccor*fact(2)*gsccorc(j,i)
 196           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 197      &                  wbond*gradbx(j,i)+
 198      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 199      &                  wsccor*fact(2)*gsccorx(j,i)
 200         enddo
 201 #else
 202       do i=1,nct
 203         do j=1,3
 204           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 205      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 206      &                wbond*gradb(j,i)+
 207      &                wcorr*fact(3)*gradcorr(j,i)+
 208      &                wel_loc*fact(2)*gel_loc(j,i)+
 209      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 210      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 211      &                wcorr5*fact(4)*gradcorr5(j,i)+
 212      &                wcorr6*fact(5)*gradcorr6(j,i)+
 213      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 214      &                wsccor*fact(2)*gsccorc(j,i)
 215           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 216      &                  wbond*gradbx(j,i)+
 217      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 218      &                  wsccor*fact(1)*gsccorx(j,i)
 219         enddo
 220 #endif
 221       enddo
 222
 223
 224       do i=1,nres-3
 225         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 226      &   +wcorr5*fact(4)*g_corr5_loc(i)
 227      &   +wcorr6*fact(5)*g_corr6_loc(i)
 228      &   +wturn4*fact(3)*gel_loc_turn4(i)
 229      &   +wturn3*fact(2)*gel_loc_turn3(i)
 230      &   +wturn6*fact(5)*gel_loc_turn6(i)
 231      &   +wel_loc*fact(2)*gel_loc_loc(i)
 232      &   +wsccor*fact(1)*gsccor_loc(i)
 233       enddo
 234       endif
 235       return
 236       end
 237 C------------------------------------------------------------------------
 238       subroutine enerprint(energia,fact)
 239       implicit real*8 (a-h,o-z)
 240       include 'DIMENSIONS'
 241       include 'sizesclu.dat'
 242       include 'COMMON.IOUNITS'
 243       include 'COMMON.FFIELD'
 244       include 'COMMON.SBRIDGE'
 245       double precision energia(0:max_ene),fact(6)
 246       etot=energia(0)
 247       evdw=energia(1)+fact(6)*energia(21)
 248 #ifdef SCP14
 249       evdw2=energia(2)+energia(17)
 250 #else
 251       evdw2=energia(2)
 252 #endif
 253       ees=energia(3)
 254 #ifdef SPLITELE
 255       evdw1=energia(16)
 256 #endif
 257       ecorr=energia(4)
 258       ecorr5=energia(5)
 259       ecorr6=energia(6)
 260       eel_loc=energia(7)
 261       eello_turn3=energia(8)
 262       eello_turn4=energia(9)
 263       eello_turn6=energia(10)
 264       ebe=energia(11)
 265       escloc=energia(12)
 266       etors=energia(13)
 267       etors_d=energia(14)
 268       ehpb=energia(15)
 269       esccor=energia(19)
 270       edihcnstr=energia(20)
 271       estr=energia(18)
 272 #ifdef SPLITELE
 273       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 274      &  wvdwpp,
 275      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 276      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 277      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 278      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 279      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 280      &  esccor,wsccor*fact(1),edihcnstr,ebr*nss,etot
 281    10 format (/'Virtual-chain energies:'//
 282      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 283      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 284      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 285      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 286      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 287      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 288      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 289      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 290      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 291      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 292      & ' (SS bridges & dist. cnstr.)'/
 293      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 294      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 295      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 296      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 297      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 298      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 299      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 300      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 301      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 302      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 303      & 'ETOT=  ',1pE16.6,' (total)')
 304 #else
 305       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 306      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 307      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 308      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 309      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 310      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 311      &  edihcnstr,ebr*nss,etot
 312    10 format (/'Virtual-chain energies:'//
 313      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 314      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 315      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 316      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 317      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 318      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 319      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 320      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 321      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 322      & ' (SS bridges & dist. cnstr.)'/
 323      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 324      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 325      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 326      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 327      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 328      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 329      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 330      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 331      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 332      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 333      & 'ETOT=  ',1pE16.6,' (total)')
 334 #endif
 335       return
 336       end
 337 C-----------------------------------------------------------------------
 338       subroutine elj(evdw,evdw_t)
 339 C
 340 C This subroutine calculates the interaction energy of nonbonded side chains
 341 C assuming the LJ potential of interaction.
 342 C
 343       implicit real*8 (a-h,o-z)
 344       include 'DIMENSIONS'
 345       include 'sizesclu.dat'
 346       include "DIMENSIONS.COMPAR"
 347       parameter (accur=1.0d-10)
 348       include 'COMMON.GEO'
 349       include 'COMMON.VAR'
 350       include 'COMMON.LOCAL'
 351       include 'COMMON.CHAIN'
 352       include 'COMMON.DERIV'
 353       include 'COMMON.INTERACT'
 354       include 'COMMON.TORSION'
 355       include 'COMMON.SBRIDGE'
 356       include 'COMMON.NAMES'
 357       include 'COMMON.IOUNITS'
 358       include 'COMMON.CONTACTS'
 359       dimension gg(3)
 360       integer icant
 361       external icant
 362 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 363       evdw=0.0D0
 364       evdw_t=0.0d0
 365       do i=iatsc_s,iatsc_e
 366         itypi=itype(i)
 367         if (itypi.eq.21) cycle
 368         itypi1=itype(i+1)
 369         xi=c(1,nres+i)
 370         yi=c(2,nres+i)
 371         zi=c(3,nres+i)
 372 C Change 12/1/95
 373         num_conti=0
 374 C
 375 C Calculate SC interaction energy.
 376 C
 377         do iint=1,nint_gr(i)
 378 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 379 cd   &                  'iend=',iend(i,iint)
 380           do j=istart(i,iint),iend(i,iint)
 381             itypj=itype(j)
 382             if (itypj.eq.21) cycle
 383             xj=c(1,nres+j)-xi
 384             yj=c(2,nres+j)-yi
 385             zj=c(3,nres+j)-zi
 386 C Change 12/1/95 to calculate four-body interactions
 387             rij=xj*xj+yj*yj+zj*zj
 388             rrij=1.0D0/rij
 389 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 390             eps0ij=eps(itypi,itypj)
 391             fac=rrij**expon2
 392             e1=fac*fac*aa(itypi,itypj)
 393             e2=fac*bb(itypi,itypj)
 394             evdwij=e1+e2
 395             ij=icant(itypi,itypj)
 396 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 397 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 398 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 399 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 400 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 401 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 402             if (bb(itypi,itypj).gt.0.0d0) then
 403               evdw=evdw+evdwij
 404             else
 405               evdw_t=evdw_t+evdwij
 406             endif
 407             if (calc_grad) then
 408 C
 409 C Calculate the components of the gradient in DC and X
 410 C
 411             fac=-rrij*(e1+evdwij)
 412             gg(1)=xj*fac
 413             gg(2)=yj*fac
 414             gg(3)=zj*fac
 415             do k=1,3
 416               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 417               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 418             enddo
 419             do k=i,j-1
 420               do l=1,3
 421                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 422               enddo
 423             enddo
 424             endif
 425 C
 426 C 12/1/95, revised on 5/20/97
 427 C
 428 C Calculate the contact function. The ith column of the array JCONT will
 429 C contain the numbers of atoms that make contacts with the atom I (of numbers
 430 C greater than I). The arrays FACONT and GACONT will contain the values of
 431 C the contact function and its derivative.
 432 C
 433 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 434 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 435 C Uncomment next line, if the correlation interactions are contact function only
 436             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 437               rij=dsqrt(rij)
 438               sigij=sigma(itypi,itypj)
 439               r0ij=rs0(itypi,itypj)
 440 C
 441 C Check whether the SC's are not too far to make a contact.
 442 C
 443               rcut=1.5d0*r0ij
 444               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 445 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 446 C
 447               if (fcont.gt.0.0D0) then
 448 C If the SC-SC distance if close to sigma, apply spline.
 449 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 450 cAdam &             fcont1,fprimcont1)
 451 cAdam           fcont1=1.0d0-fcont1
 452 cAdam           if (fcont1.gt.0.0d0) then
 453 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 454 cAdam             fcont=fcont*fcont1
 455 cAdam           endif
 456 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 457 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 458 cga             do k=1,3
 459 cga               gg(k)=gg(k)*eps0ij
 460 cga             enddo
 461 cga             eps0ij=-evdwij*eps0ij
 462 C Uncomment for AL's type of SC correlation interactions.
 463 cadam           eps0ij=-evdwij
 464                 num_conti=num_conti+1
 465                 jcont(num_conti,i)=j
 466                 facont(num_conti,i)=fcont*eps0ij
 467                 fprimcont=eps0ij*fprimcont/rij
 468                 fcont=expon*fcont
 469 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 470 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 471 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 472 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 473                 gacont(1,num_conti,i)=-fprimcont*xj
 474                 gacont(2,num_conti,i)=-fprimcont*yj
 475                 gacont(3,num_conti,i)=-fprimcont*zj
 476 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 477 cd              write (iout,'(2i3,3f10.5)')
 478 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 479               endif
 480             endif
 481           enddo      ! j
 482         enddo        ! iint
 483 C Change 12/1/95
 484         num_cont(i)=num_conti
 485       enddo          ! i
 486       if (calc_grad) then
 487       do i=1,nct
 488         do j=1,3
 489           gvdwc(j,i)=expon*gvdwc(j,i)
 490           gvdwx(j,i)=expon*gvdwx(j,i)
 491         enddo
 492       enddo
 493       endif
 494 C******************************************************************************
 495 C
 496 C                              N O T E !!!
 497 C
 498 C To save time, the factor of EXPON has been extracted from ALL components
 499 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 500 C use!
 501 C
 502 C******************************************************************************
 503       return
 504       end
 505 C-----------------------------------------------------------------------------
 506       subroutine eljk(evdw,evdw_t)
 507 C
 508 C This subroutine calculates the interaction energy of nonbonded side chains
 509 C assuming the LJK potential of interaction.
 510 C
 511       implicit real*8 (a-h,o-z)
 512       include 'DIMENSIONS'
 513       include 'sizesclu.dat'
 514       include "DIMENSIONS.COMPAR"
 515       include 'COMMON.GEO'
 516       include 'COMMON.VAR'
 517       include 'COMMON.LOCAL'
 518       include 'COMMON.CHAIN'
 519       include 'COMMON.DERIV'
 520       include 'COMMON.INTERACT'
 521       include 'COMMON.IOUNITS'
 522       include 'COMMON.NAMES'
 523       dimension gg(3)
 524       logical scheck
 525       integer icant
 526       external icant
 527 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 528       evdw=0.0D0
 529       evdw_t=0.0d0
 530       do i=iatsc_s,iatsc_e
 531         itypi=itype(i)
 532         if (itypi.eq.21) cycle
 533         itypi1=itype(i+1)
 534         xi=c(1,nres+i)
 535         yi=c(2,nres+i)
 536         zi=c(3,nres+i)
 537 C
 538 C Calculate SC interaction energy.
 539 C
 540         do iint=1,nint_gr(i)
 541           do j=istart(i,iint),iend(i,iint)
 542             itypj=itype(j)
 543             if (itypj.eq.21) cycle
 544             xj=c(1,nres+j)-xi
 545             yj=c(2,nres+j)-yi
 546             zj=c(3,nres+j)-zi
 547             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 548             fac_augm=rrij**expon
 549             e_augm=augm(itypi,itypj)*fac_augm
 550             r_inv_ij=dsqrt(rrij)
 551             rij=1.0D0/r_inv_ij
 552             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 553             fac=r_shift_inv**expon
 554             e1=fac*fac*aa(itypi,itypj)
 555             e2=fac*bb(itypi,itypj)
 556             evdwij=e_augm+e1+e2
 557             ij=icant(itypi,itypj)
 558 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 559 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 560 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 561 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 562 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 563 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 564 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 565             if (bb(itypi,itypj).gt.0.0d0) then
 566               evdw=evdw+evdwij
 567             else
 568               evdw_t=evdw_t+evdwij
 569             endif
 570             if (calc_grad) then
 571 C
 572 C Calculate the components of the gradient in DC and X
 573 C
 574             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 575             gg(1)=xj*fac
 576             gg(2)=yj*fac
 577             gg(3)=zj*fac
 578             do k=1,3
 579               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 580               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 581             enddo
 582             do k=i,j-1
 583               do l=1,3
 584                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 585               enddo
 586             enddo
 587             endif
 588           enddo      ! j
 589         enddo        ! iint
 590       enddo          ! i
 591       if (calc_grad) then
 592       do i=1,nct
 593         do j=1,3
 594           gvdwc(j,i)=expon*gvdwc(j,i)
 595           gvdwx(j,i)=expon*gvdwx(j,i)
 596         enddo
 597       enddo
 598       endif
 599       return
 600       end
 601 C-----------------------------------------------------------------------------
 602       subroutine ebp(evdw,evdw_t)
 603 C
 604 C This subroutine calculates the interaction energy of nonbonded side chains
 605 C assuming the Berne-Pechukas potential of interaction.
 606 C
 607       implicit real*8 (a-h,o-z)
 608       include 'DIMENSIONS'
 609       include 'sizesclu.dat'
 610       include "DIMENSIONS.COMPAR"
 611       include 'COMMON.GEO'
 612       include 'COMMON.VAR'
 613       include 'COMMON.LOCAL'
 614       include 'COMMON.CHAIN'
 615       include 'COMMON.DERIV'
 616       include 'COMMON.NAMES'
 617       include 'COMMON.INTERACT'
 618       include 'COMMON.IOUNITS'
 619       include 'COMMON.CALC'
 620       common /srutu/ icall
 621 c     double precision rrsave(maxdim)
 622       logical lprn
 623       integer icant
 624       external icant
 625       evdw=0.0D0
 626       evdw_t=0.0d0
 627 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 628 c     if (icall.eq.0) then
 629 c       lprn=.true.
 630 c     else
 631         lprn=.false.
 632 c     endif
 633       ind=0
 634       do i=iatsc_s,iatsc_e
 635         itypi=itype(i)
 636         if (itypi.eq.21) cycle
 637         itypi1=itype(i+1)
 638         xi=c(1,nres+i)
 639         yi=c(2,nres+i)
 640         zi=c(3,nres+i)
 641         dxi=dc_norm(1,nres+i)
 642         dyi=dc_norm(2,nres+i)
 643         dzi=dc_norm(3,nres+i)
 644         dsci_inv=vbld_inv(i+nres)
 645 C
 646 C Calculate SC interaction energy.
 647 C
 648         do iint=1,nint_gr(i)
 649           do j=istart(i,iint),iend(i,iint)
 650             ind=ind+1
 651             itypj=itype(j)
 652             if (itypj.eq.21) cycle
 653             dscj_inv=vbld_inv(j+nres)
 654             chi1=chi(itypi,itypj)
 655             chi2=chi(itypj,itypi)
 656             chi12=chi1*chi2
 657             chip1=chip(itypi)
 658             chip2=chip(itypj)
 659             chip12=chip1*chip2
 660             alf1=alp(itypi)
 661             alf2=alp(itypj)
 662             alf12=0.5D0*(alf1+alf2)
 663 C For diagnostics only!!!
 664 c           chi1=0.0D0
 665 c           chi2=0.0D0
 666 c           chi12=0.0D0
 667 c           chip1=0.0D0
 668 c           chip2=0.0D0
 669 c           chip12=0.0D0
 670 c           alf1=0.0D0
 671 c           alf2=0.0D0
 672 c           alf12=0.0D0
 673             xj=c(1,nres+j)-xi
 674             yj=c(2,nres+j)-yi
 675             zj=c(3,nres+j)-zi
 676             dxj=dc_norm(1,nres+j)
 677             dyj=dc_norm(2,nres+j)
 678             dzj=dc_norm(3,nres+j)
 679             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 680 cd          if (icall.eq.0) then
 681 cd            rrsave(ind)=rrij
 682 cd          else
 683 cd            rrij=rrsave(ind)
 684 cd          endif
 685             rij=dsqrt(rrij)
 686 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 687             call sc_angular
 688 C Calculate whole angle-dependent part of epsilon and contributions
 689 C to its derivatives
 690             fac=(rrij*sigsq)**expon2
 691             e1=fac*fac*aa(itypi,itypj)
 692             e2=fac*bb(itypi,itypj)
 693             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 694             eps2der=evdwij*eps3rt
 695             eps3der=evdwij*eps2rt
 696             evdwij=evdwij*eps2rt*eps3rt
 697             ij=icant(itypi,itypj)
 698             aux=eps1*eps2rt**2*eps3rt**2
 699             if (bb(itypi,itypj).gt.0.0d0) then
 700               evdw=evdw+evdwij
 701             else
 702               evdw_t=evdw_t+evdwij
 703             endif
 704             if (calc_grad) then
 705             if (lprn) then
 706             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 707             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 708 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 709 cd     &        restyp(itypi),i,restyp(itypj),j,
 710 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 711 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 712 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 713 cd     &        evdwij
 714             endif
 715 C Calculate gradient components.
 716             e1=e1*eps1*eps2rt**2*eps3rt**2
 717             fac=-expon*(e1+evdwij)
 718             sigder=fac/sigsq
 719             fac=rrij*fac
 720 C Calculate radial part of the gradient
 721             gg(1)=xj*fac
 722             gg(2)=yj*fac
 723             gg(3)=zj*fac
 724 C Calculate the angular part of the gradient and sum add the contributions
 725 C to the appropriate components of the Cartesian gradient.
 726             call sc_grad
 727             endif
 728           enddo      ! j
 729         enddo        ! iint
 730       enddo          ! i
 731 c     stop
 732       return
 733       end
 734 C-----------------------------------------------------------------------------
 735       subroutine egb(evdw,evdw_t)
 736 C
 737 C This subroutine calculates the interaction energy of nonbonded side chains
 738 C assuming the Gay-Berne potential of interaction.
 739 C
 740       implicit real*8 (a-h,o-z)
 741       include 'DIMENSIONS'
 742       include 'sizesclu.dat'
 743       include "DIMENSIONS.COMPAR"
 744       include 'COMMON.GEO'
 745       include 'COMMON.VAR'
 746       include 'COMMON.LOCAL'
 747       include 'COMMON.CHAIN'
 748       include 'COMMON.DERIV'
 749       include 'COMMON.NAMES'
 750       include 'COMMON.INTERACT'
 751       include 'COMMON.IOUNITS'
 752       include 'COMMON.CALC'
 753       logical lprn
 754       common /srutu/icall
 755       integer icant
 756       external icant
 757 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 758       evdw=0.0D0
 759       evdw_t=0.0d0
 760       lprn=.false.
 761 c      if (icall.gt.0) lprn=.true.
 762       ind=0
 763       do i=iatsc_s,iatsc_e
 764         itypi=itype(i)
 765         if (itypi.eq.21) cycle
 766         itypi1=itype(i+1)
 767         xi=c(1,nres+i)
 768         yi=c(2,nres+i)
 769         zi=c(3,nres+i)
 770         dxi=dc_norm(1,nres+i)
 771         dyi=dc_norm(2,nres+i)
 772         dzi=dc_norm(3,nres+i)
 773         dsci_inv=vbld_inv(i+nres)
 774 C
 775 C Calculate SC interaction energy.
 776 C
 777         do iint=1,nint_gr(i)
 778           do j=istart(i,iint),iend(i,iint)
 779             ind=ind+1
 780             itypj=itype(j)
 781             if (itypj.eq.21) cycle
 782             dscj_inv=vbld_inv(j+nres)
 783             sig0ij=sigma(itypi,itypj)
 784             chi1=chi(itypi,itypj)
 785             chi2=chi(itypj,itypi)
 786             chi12=chi1*chi2
 787             chip1=chip(itypi)
 788             chip2=chip(itypj)
 789             chip12=chip1*chip2
 790             alf1=alp(itypi)
 791             alf2=alp(itypj)
 792             alf12=0.5D0*(alf1+alf2)
 793 C For diagnostics only!!!
 794 c           chi1=0.0D0
 795 c           chi2=0.0D0
 796 c           chi12=0.0D0
 797 c           chip1=0.0D0
 798 c           chip2=0.0D0
 799 c           chip12=0.0D0
 800 c           alf1=0.0D0
 801 c           alf2=0.0D0
 802 c           alf12=0.0D0
 803             xj=c(1,nres+j)-xi
 804             yj=c(2,nres+j)-yi
 805             zj=c(3,nres+j)-zi
 806             dxj=dc_norm(1,nres+j)
 807             dyj=dc_norm(2,nres+j)
 808             dzj=dc_norm(3,nres+j)
 809 c            write (iout,*) i,j,xj,yj,zj
 810             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 811             rij=dsqrt(rrij)
 812 C Calculate angle-dependent terms of energy and contributions to their
 813 C derivatives.
 814             call sc_angular
 815             sigsq=1.0D0/sigsq
 816             sig=sig0ij*dsqrt(sigsq)
 817             rij_shift=1.0D0/rij-sig+sig0ij
 818 C I hate to put IF's in the loops, but here don't have another choice!!!!
 819             if (rij_shift.le.0.0D0) then
 820               evdw=1.0D20
 821               return
 822             endif
 823             sigder=-sig*sigsq
 824 c---------------------------------------------------------------
 825             rij_shift=1.0D0/rij_shift
 826             fac=rij_shift**expon
 827             e1=fac*fac*aa(itypi,itypj)
 828             e2=fac*bb(itypi,itypj)
 829             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 830             eps2der=evdwij*eps3rt
 831             eps3der=evdwij*eps2rt
 832             evdwij=evdwij*eps2rt*eps3rt
 833             if (bb(itypi,itypj).gt.0) then
 834               evdw=evdw+evdwij
 835             else
 836               evdw_t=evdw_t+evdwij
 837             endif
 838             ij=icant(itypi,itypj)
 839             aux=eps1*eps2rt**2*eps3rt**2
 840 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 841 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 842 c     &         aux*e2/eps(itypi,itypj)
 843 c            if (lprn) then
 844             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 845             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 846 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 847 c     &        restyp(itypi),i,restyp(itypj),j,
 848 c     &        epsi,sigm,chi1,chi2,chip1,chip2,
 849 c     &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 850 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 851 c     &        evdwij
 852 c             write (iout,*) "pratial sum", evdw,evdw_t
 853 c            endif
 854             if (calc_grad) then
 855 C Calculate gradient components.
 856             e1=e1*eps1*eps2rt**2*eps3rt**2
 857             fac=-expon*(e1+evdwij)*rij_shift
 858             sigder=fac*sigder
 859             fac=rij*fac
 860 C Calculate the radial part of the gradient
 861             gg(1)=xj*fac
 862             gg(2)=yj*fac
 863             gg(3)=zj*fac
 864 C Calculate angular part of the gradient.
 865             call sc_grad
 866             endif
 867           enddo      ! j
 868         enddo        ! iint
 869       enddo          ! i
 870       return
 871       end
 872 C-----------------------------------------------------------------------------
 873       subroutine egbv(evdw,evdw_t)
 874 C
 875 C This subroutine calculates the interaction energy of nonbonded side chains
 876 C assuming the Gay-Berne-Vorobjev potential of interaction.
 877 C
 878       implicit real*8 (a-h,o-z)
 879       include 'DIMENSIONS'
 880       include 'sizesclu.dat'
 881       include "DIMENSIONS.COMPAR"
 882       include 'COMMON.GEO'
 883       include 'COMMON.VAR'
 884       include 'COMMON.LOCAL'
 885       include 'COMMON.CHAIN'
 886       include 'COMMON.DERIV'
 887       include 'COMMON.NAMES'
 888       include 'COMMON.INTERACT'
 889       include 'COMMON.IOUNITS'
 890       include 'COMMON.CALC'
 891       common /srutu/ icall
 892       logical lprn
 893       integer icant
 894       external icant
 895       evdw=0.0D0
 896       evdw_t=0.0d0
 897 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 898       evdw=0.0D0
 899       lprn=.false.
 900 c      if (icall.gt.0) lprn=.true.
 901       ind=0
 902       do i=iatsc_s,iatsc_e
 903         itypi=itype(i)
 904         if (itypi.eq.21) cycle
 905         itypi1=itype(i+1)
 906         xi=c(1,nres+i)
 907         yi=c(2,nres+i)
 908         zi=c(3,nres+i)
 909         dxi=dc_norm(1,nres+i)
 910         dyi=dc_norm(2,nres+i)
 911         dzi=dc_norm(3,nres+i)
 912         dsci_inv=vbld_inv(i+nres)
 913 C
 914 C Calculate SC interaction energy.
 915 C
 916         do iint=1,nint_gr(i)
 917           do j=istart(i,iint),iend(i,iint)
 918             ind=ind+1
 919             itypj=itype(j)
 920             if (itypj.eq.21) cycle
 921             dscj_inv=vbld_inv(j+nres)
 922             sig0ij=sigma(itypi,itypj)
 923             r0ij=r0(itypi,itypj)
 924             chi1=chi(itypi,itypj)
 925             chi2=chi(itypj,itypi)
 926             chi12=chi1*chi2
 927             chip1=chip(itypi)
 928             chip2=chip(itypj)
 929             chip12=chip1*chip2
 930             alf1=alp(itypi)
 931             alf2=alp(itypj)
 932             alf12=0.5D0*(alf1+alf2)
 933 C For diagnostics only!!!
 934 c           chi1=0.0D0
 935 c           chi2=0.0D0
 936 c           chi12=0.0D0
 937 c           chip1=0.0D0
 938 c           chip2=0.0D0
 939 c           chip12=0.0D0
 940 c           alf1=0.0D0
 941 c           alf2=0.0D0
 942 c           alf12=0.0D0
 943             xj=c(1,nres+j)-xi
 944             yj=c(2,nres+j)-yi
 945             zj=c(3,nres+j)-zi
 946             dxj=dc_norm(1,nres+j)
 947             dyj=dc_norm(2,nres+j)
 948             dzj=dc_norm(3,nres+j)
 949             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 950             rij=dsqrt(rrij)
 951 C Calculate angle-dependent terms of energy and contributions to their
 952 C derivatives.
 953             call sc_angular
 954             sigsq=1.0D0/sigsq
 955             sig=sig0ij*dsqrt(sigsq)
 956             rij_shift=1.0D0/rij-sig+r0ij
 957 C I hate to put IF's in the loops, but here don't have another choice!!!!
 958             if (rij_shift.le.0.0D0) then
 959               evdw=1.0D20
 960               return
 961             endif
 962             sigder=-sig*sigsq
 963 c---------------------------------------------------------------
 964             rij_shift=1.0D0/rij_shift
 965             fac=rij_shift**expon
 966             e1=fac*fac*aa(itypi,itypj)
 967             e2=fac*bb(itypi,itypj)
 968             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 969             eps2der=evdwij*eps3rt
 970             eps3der=evdwij*eps2rt
 971             fac_augm=rrij**expon
 972             e_augm=augm(itypi,itypj)*fac_augm
 973             evdwij=evdwij*eps2rt*eps3rt
 974             if (bb(itypi,itypj).gt.0.0d0) then
 975               evdw=evdw+evdwij+e_augm
 976             else
 977               evdw_t=evdw_t+evdwij+e_augm
 978             endif
 979             ij=icant(itypi,itypj)
 980             aux=eps1*eps2rt**2*eps3rt**2
 981 c            if (lprn) then
 982 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 983 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 984 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 985 c     &        restyp(itypi),i,restyp(itypj),j,
 986 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
 987 c     &        chi1,chi2,chip1,chip2,
 988 c     &        eps1,eps2rt**2,eps3rt**2,
 989 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 990 c     &        evdwij+e_augm
 991 c            endif
 992             if (calc_grad) then
 993 C Calculate gradient components.
 994             e1=e1*eps1*eps2rt**2*eps3rt**2
 995             fac=-expon*(e1+evdwij)*rij_shift
 996             sigder=fac*sigder
 997             fac=rij*fac-2*expon*rrij*e_augm
 998 C Calculate the radial part of the gradient
 999             gg(1)=xj*fac
1000             gg(2)=yj*fac
1001             gg(3)=zj*fac
1002 C Calculate angular part of the gradient.
1003             call sc_grad
1004             endif
1005           enddo      ! j
1006         enddo        ! iint
1007       enddo          ! i
1008       return
1009       end
1010 C-----------------------------------------------------------------------------
1011       subroutine sc_angular
1012 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1013 C om12. Called by ebp, egb, and egbv.
1014       implicit none
1015       include 'COMMON.CALC'
1016       erij(1)=xj*rij
1017       erij(2)=yj*rij
1018       erij(3)=zj*rij
1019       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1020       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1021       om12=dxi*dxj+dyi*dyj+dzi*dzj
1022       chiom12=chi12*om12
1023 C Calculate eps1(om12) and its derivative in om12
1024       faceps1=1.0D0-om12*chiom12
1025       faceps1_inv=1.0D0/faceps1
1026       eps1=dsqrt(faceps1_inv)
1027 C Following variable is eps1*deps1/dom12
1028       eps1_om12=faceps1_inv*chiom12
1029 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1030 C and om12.
1031       om1om2=om1*om2
1032       chiom1=chi1*om1
1033       chiom2=chi2*om2
1034       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1035       sigsq=1.0D0-facsig*faceps1_inv
1036       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1037       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1038       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1039 C Calculate eps2 and its derivatives in om1, om2, and om12.
1040       chipom1=chip1*om1
1041       chipom2=chip2*om2
1042       chipom12=chip12*om12
1043       facp=1.0D0-om12*chipom12
1044       facp_inv=1.0D0/facp
1045       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1046 C Following variable is the square root of eps2
1047       eps2rt=1.0D0-facp1*facp_inv
1048 C Following three variables are the derivatives of the square root of eps
1049 C in om1, om2, and om12.
1050       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1051       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1052       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1053 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1054       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1055 C Calculate whole angle-dependent part of epsilon and contributions
1056 C to its derivatives
1057       return
1058       end
1059 C----------------------------------------------------------------------------
1060       subroutine sc_grad
1061       implicit real*8 (a-h,o-z)
1062       include 'DIMENSIONS'
1063       include 'sizesclu.dat'
1064       include 'COMMON.CHAIN'
1065       include 'COMMON.DERIV'
1066       include 'COMMON.CALC'
1067       double precision dcosom1(3),dcosom2(3)
1068       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1069       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1070       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1071      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1072       do k=1,3
1073         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1074         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1075       enddo
1076       do k=1,3
1077         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1078       enddo
1079       do k=1,3
1080         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1081      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1082      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1083         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1084      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1085      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1086       enddo
1087 C
1088 C Calculate the components of the gradient in DC and X
1089 C
1090       do k=i,j-1
1091         do l=1,3
1092           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1093         enddo
1094       enddo
1095       return
1096       end
1097 c------------------------------------------------------------------------------
1098       subroutine vec_and_deriv
1099       implicit real*8 (a-h,o-z)
1100       include 'DIMENSIONS'
1101       include 'sizesclu.dat'
1102       include 'COMMON.IOUNITS'
1103       include 'COMMON.GEO'
1104       include 'COMMON.VAR'
1105       include 'COMMON.LOCAL'
1106       include 'COMMON.CHAIN'
1107       include 'COMMON.VECTORS'
1108       include 'COMMON.DERIV'
1109       include 'COMMON.INTERACT'
1110       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1111 C Compute the local reference systems. For reference system (i), the
1112 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1113 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1114       do i=1,nres-1
1115 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1116           if (i.eq.nres-1) then
1117 C Case of the last full residue
1118 C Compute the Z-axis
1119             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1120             costh=dcos(pi-theta(nres))
1121             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1122             do k=1,3
1123               uz(k,i)=fac*uz(k,i)
1124             enddo
1125             if (calc_grad) then
1126 C Compute the derivatives of uz
1127             uzder(1,1,1)= 0.0d0
1128             uzder(2,1,1)=-dc_norm(3,i-1)
1129             uzder(3,1,1)= dc_norm(2,i-1)
1130             uzder(1,2,1)= dc_norm(3,i-1)
1131             uzder(2,2,1)= 0.0d0
1132             uzder(3,2,1)=-dc_norm(1,i-1)
1133             uzder(1,3,1)=-dc_norm(2,i-1)
1134             uzder(2,3,1)= dc_norm(1,i-1)
1135             uzder(3,3,1)= 0.0d0
1136             uzder(1,1,2)= 0.0d0
1137             uzder(2,1,2)= dc_norm(3,i)
1138             uzder(3,1,2)=-dc_norm(2,i)
1139             uzder(1,2,2)=-dc_norm(3,i)
1140             uzder(2,2,2)= 0.0d0
1141             uzder(3,2,2)= dc_norm(1,i)
1142             uzder(1,3,2)= dc_norm(2,i)
1143             uzder(2,3,2)=-dc_norm(1,i)
1144             uzder(3,3,2)= 0.0d0
1145             endif
1146 C Compute the Y-axis
1147             facy=fac
1148             do k=1,3
1149               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1150             enddo
1151             if (calc_grad) then
1152 C Compute the derivatives of uy
1153             do j=1,3
1154               do k=1,3
1155                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1156      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1157                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1158               enddo
1159               uyder(j,j,1)=uyder(j,j,1)-costh
1160               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1161             enddo
1162             do j=1,2
1163               do k=1,3
1164                 do l=1,3
1165                   uygrad(l,k,j,i)=uyder(l,k,j)
1166                   uzgrad(l,k,j,i)=uzder(l,k,j)
1167                 enddo
1168               enddo
1169             enddo
1170             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1171             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1172             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1173             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1174             endif
1175           else
1176 C Other residues
1177 C Compute the Z-axis
1178             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1179             costh=dcos(pi-theta(i+2))
1180             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1181             do k=1,3
1182               uz(k,i)=fac*uz(k,i)
1183             enddo
1184             if (calc_grad) then
1185 C Compute the derivatives of uz
1186             uzder(1,1,1)= 0.0d0
1187             uzder(2,1,1)=-dc_norm(3,i+1)
1188             uzder(3,1,1)= dc_norm(2,i+1)
1189             uzder(1,2,1)= dc_norm(3,i+1)
1190             uzder(2,2,1)= 0.0d0
1191             uzder(3,2,1)=-dc_norm(1,i+1)
1192             uzder(1,3,1)=-dc_norm(2,i+1)
1193             uzder(2,3,1)= dc_norm(1,i+1)
1194             uzder(3,3,1)= 0.0d0
1195             uzder(1,1,2)= 0.0d0
1196             uzder(2,1,2)= dc_norm(3,i)
1197             uzder(3,1,2)=-dc_norm(2,i)
1198             uzder(1,2,2)=-dc_norm(3,i)
1199             uzder(2,2,2)= 0.0d0
1200             uzder(3,2,2)= dc_norm(1,i)
1201             uzder(1,3,2)= dc_norm(2,i)
1202             uzder(2,3,2)=-dc_norm(1,i)
1203             uzder(3,3,2)= 0.0d0
1204             endif
1205 C Compute the Y-axis
1206             facy=fac
1207             do k=1,3
1208               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1209             enddo
1210             if (calc_grad) then
1211 C Compute the derivatives of uy
1212             do j=1,3
1213               do k=1,3
1214                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1215      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1216                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1217               enddo
1218               uyder(j,j,1)=uyder(j,j,1)-costh
1219               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1220             enddo
1221             do j=1,2
1222               do k=1,3
1223                 do l=1,3
1224                   uygrad(l,k,j,i)=uyder(l,k,j)
1225                   uzgrad(l,k,j,i)=uzder(l,k,j)
1226                 enddo
1227               enddo
1228             enddo
1229             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1230             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1231             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1232             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1233           endif
1234           endif
1235       enddo
1236       if (calc_grad) then
1237       do i=1,nres-1
1238         vbld_inv_temp(1)=vbld_inv(i+1)
1239         if (i.lt.nres-1) then
1240           vbld_inv_temp(2)=vbld_inv(i+2)
1241         else
1242           vbld_inv_temp(2)=vbld_inv(i)
1243         endif
1244         do j=1,2
1245           do k=1,3
1246             do l=1,3
1247               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1248               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1249             enddo
1250           enddo
1251         enddo
1252       enddo
1253       endif
1254       return
1255       end
1256 C-----------------------------------------------------------------------------
1257       subroutine vec_and_deriv_test
1258       implicit real*8 (a-h,o-z)
1259       include 'DIMENSIONS'
1260       include 'sizesclu.dat'
1261       include 'COMMON.IOUNITS'
1262       include 'COMMON.GEO'
1263       include 'COMMON.VAR'
1264       include 'COMMON.LOCAL'
1265       include 'COMMON.CHAIN'
1266       include 'COMMON.VECTORS'
1267       dimension uyder(3,3,2),uzder(3,3,2)
1268 C Compute the local reference systems. For reference system (i), the
1269 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1270 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1271       do i=1,nres-1
1272           if (i.eq.nres-1) then
1273 C Case of the last full residue
1274 C Compute the Z-axis
1275             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1276             costh=dcos(pi-theta(nres))
1277             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1278 c            write (iout,*) 'fac',fac,
1279 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1280             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1281             do k=1,3
1282               uz(k,i)=fac*uz(k,i)
1283             enddo
1284 C Compute the derivatives of uz
1285             uzder(1,1,1)= 0.0d0
1286             uzder(2,1,1)=-dc_norm(3,i-1)
1287             uzder(3,1,1)= dc_norm(2,i-1)
1288             uzder(1,2,1)= dc_norm(3,i-1)
1289             uzder(2,2,1)= 0.0d0
1290             uzder(3,2,1)=-dc_norm(1,i-1)
1291             uzder(1,3,1)=-dc_norm(2,i-1)
1292             uzder(2,3,1)= dc_norm(1,i-1)
1293             uzder(3,3,1)= 0.0d0
1294             uzder(1,1,2)= 0.0d0
1295             uzder(2,1,2)= dc_norm(3,i)
1296             uzder(3,1,2)=-dc_norm(2,i)
1297             uzder(1,2,2)=-dc_norm(3,i)
1298             uzder(2,2,2)= 0.0d0
1299             uzder(3,2,2)= dc_norm(1,i)
1300             uzder(1,3,2)= dc_norm(2,i)
1301             uzder(2,3,2)=-dc_norm(1,i)
1302             uzder(3,3,2)= 0.0d0
1303 C Compute the Y-axis
1304             do k=1,3
1305               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1306             enddo
1307             facy=fac
1308             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1309      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1310      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1311             do k=1,3
1312 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1313               uy(k,i)=
1314 c     &        facy*(
1315      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1316      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1317 c     &        )
1318             enddo
1319 c            write (iout,*) 'facy',facy,
1320 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1321             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1322             do k=1,3
1323               uy(k,i)=facy*uy(k,i)
1324             enddo
1325 C Compute the derivatives of uy
1326             do j=1,3
1327               do k=1,3
1328                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1329      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1330                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1331               enddo
1332 c              uyder(j,j,1)=uyder(j,j,1)-costh
1333 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1334               uyder(j,j,1)=uyder(j,j,1)
1335      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1336               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1337      &          +uyder(j,j,2)
1338             enddo
1339             do j=1,2
1340               do k=1,3
1341                 do l=1,3
1342                   uygrad(l,k,j,i)=uyder(l,k,j)
1343                   uzgrad(l,k,j,i)=uzder(l,k,j)
1344                 enddo
1345               enddo
1346             enddo
1347             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1348             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1349             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1350             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1351           else
1352 C Other residues
1353 C Compute the Z-axis
1354             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1355             costh=dcos(pi-theta(i+2))
1356             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1357             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1358             do k=1,3
1359               uz(k,i)=fac*uz(k,i)
1360             enddo
1361 C Compute the derivatives of uz
1362             uzder(1,1,1)= 0.0d0
1363             uzder(2,1,1)=-dc_norm(3,i+1)
1364             uzder(3,1,1)= dc_norm(2,i+1)
1365             uzder(1,2,1)= dc_norm(3,i+1)
1366             uzder(2,2,1)= 0.0d0
1367             uzder(3,2,1)=-dc_norm(1,i+1)
1368             uzder(1,3,1)=-dc_norm(2,i+1)
1369             uzder(2,3,1)= dc_norm(1,i+1)
1370             uzder(3,3,1)= 0.0d0
1371             uzder(1,1,2)= 0.0d0
1372             uzder(2,1,2)= dc_norm(3,i)
1373             uzder(3,1,2)=-dc_norm(2,i)
1374             uzder(1,2,2)=-dc_norm(3,i)
1375             uzder(2,2,2)= 0.0d0
1376             uzder(3,2,2)= dc_norm(1,i)
1377             uzder(1,3,2)= dc_norm(2,i)
1378             uzder(2,3,2)=-dc_norm(1,i)
1379             uzder(3,3,2)= 0.0d0
1380 C Compute the Y-axis
1381             facy=fac
1382             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1383      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1384      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1385             do k=1,3
1386 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1387               uy(k,i)=
1388 c     &        facy*(
1389      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1390      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1391 c     &        )
1392             enddo
1393 c            write (iout,*) 'facy',facy,
1394 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1395             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1396             do k=1,3
1397               uy(k,i)=facy*uy(k,i)
1398             enddo
1399 C Compute the derivatives of uy
1400             do j=1,3
1401               do k=1,3
1402                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1403      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1404                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1405               enddo
1406 c              uyder(j,j,1)=uyder(j,j,1)-costh
1407 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1408               uyder(j,j,1)=uyder(j,j,1)
1409      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1410               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1411      &          +uyder(j,j,2)
1412             enddo
1413             do j=1,2
1414               do k=1,3
1415                 do l=1,3
1416                   uygrad(l,k,j,i)=uyder(l,k,j)
1417                   uzgrad(l,k,j,i)=uzder(l,k,j)
1418                 enddo
1419               enddo
1420             enddo
1421             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1422             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1423             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1424             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1425           endif
1426       enddo
1427       do i=1,nres-1
1428         do j=1,2
1429           do k=1,3
1430             do l=1,3
1431               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1432               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1433             enddo
1434           enddo
1435         enddo
1436       enddo
1437       return
1438       end
1439 C-----------------------------------------------------------------------------
1440       subroutine check_vecgrad
1441       implicit real*8 (a-h,o-z)
1442       include 'DIMENSIONS'
1443       include 'sizesclu.dat'
1444       include 'COMMON.IOUNITS'
1445       include 'COMMON.GEO'
1446       include 'COMMON.VAR'
1447       include 'COMMON.LOCAL'
1448       include 'COMMON.CHAIN'
1449       include 'COMMON.VECTORS'
1450       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1451       dimension uyt(3,maxres),uzt(3,maxres)
1452       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1453       double precision delta /1.0d-7/
1454       call vec_and_deriv
1455 cd      do i=1,nres
1456 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1457 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1458 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1459 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1460 cd     &     (dc_norm(if90,i),if90=1,3)
1461 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1462 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1463 cd          write(iout,'(a)')
1464 cd      enddo
1465       do i=1,nres
1466         do j=1,2
1467           do k=1,3
1468             do l=1,3
1469               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1470               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1471             enddo
1472           enddo
1473         enddo
1474       enddo
1475       call vec_and_deriv
1476       do i=1,nres
1477         do j=1,3
1478           uyt(j,i)=uy(j,i)
1479           uzt(j,i)=uz(j,i)
1480         enddo
1481       enddo
1482       do i=1,nres
1483 cd        write (iout,*) 'i=',i
1484         do k=1,3
1485           erij(k)=dc_norm(k,i)
1486         enddo
1487         do j=1,3
1488           do k=1,3
1489             dc_norm(k,i)=erij(k)
1490           enddo
1491           dc_norm(j,i)=dc_norm(j,i)+delta
1492 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1493 c          do k=1,3
1494 c            dc_norm(k,i)=dc_norm(k,i)/fac
1495 c          enddo
1496 c          write (iout,*) (dc_norm(k,i),k=1,3)
1497 c          write (iout,*) (erij(k),k=1,3)
1498           call vec_and_deriv
1499           do k=1,3
1500             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1501             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1502             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1503             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1504           enddo
1505 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1506 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1507 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1508         enddo
1509         do k=1,3
1510           dc_norm(k,i)=erij(k)
1511         enddo
1512 cd        do k=1,3
1513 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1514 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1515 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1516 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1517 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1518 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1519 cd          write (iout,'(a)')
1520 cd        enddo
1521       enddo
1522       return
1523       end
1524 C--------------------------------------------------------------------------
1525       subroutine set_matrices
1526       implicit real*8 (a-h,o-z)
1527       include 'DIMENSIONS'
1528       include 'sizesclu.dat'
1529       include 'COMMON.IOUNITS'
1530       include 'COMMON.GEO'
1531       include 'COMMON.VAR'
1532       include 'COMMON.LOCAL'
1533       include 'COMMON.CHAIN'
1534       include 'COMMON.DERIV'
1535       include 'COMMON.INTERACT'
1536       include 'COMMON.CONTACTS'
1537       include 'COMMON.TORSION'
1538       include 'COMMON.VECTORS'
1539       include 'COMMON.FFIELD'
1540       double precision auxvec(2),auxmat(2,2)
1541 C
1542 C Compute the virtual-bond-torsional-angle dependent quantities needed
1543 C to calculate the el-loc multibody terms of various order.
1544 C
1545       do i=3,nres+1
1546         if (i .lt. nres+1) then
1547           sin1=dsin(phi(i))
1548           cos1=dcos(phi(i))
1549           sintab(i-2)=sin1
1550           costab(i-2)=cos1
1551           obrot(1,i-2)=cos1
1552           obrot(2,i-2)=sin1
1553           sin2=dsin(2*phi(i))
1554           cos2=dcos(2*phi(i))
1555           sintab2(i-2)=sin2
1556           costab2(i-2)=cos2
1557           obrot2(1,i-2)=cos2
1558           obrot2(2,i-2)=sin2
1559           Ug(1,1,i-2)=-cos1
1560           Ug(1,2,i-2)=-sin1
1561           Ug(2,1,i-2)=-sin1
1562           Ug(2,2,i-2)= cos1
1563           Ug2(1,1,i-2)=-cos2
1564           Ug2(1,2,i-2)=-sin2
1565           Ug2(2,1,i-2)=-sin2
1566           Ug2(2,2,i-2)= cos2
1567         else
1568           costab(i-2)=1.0d0
1569           sintab(i-2)=0.0d0
1570           obrot(1,i-2)=1.0d0
1571           obrot(2,i-2)=0.0d0
1572           obrot2(1,i-2)=0.0d0
1573           obrot2(2,i-2)=0.0d0
1574           Ug(1,1,i-2)=1.0d0
1575           Ug(1,2,i-2)=0.0d0
1576           Ug(2,1,i-2)=0.0d0
1577           Ug(2,2,i-2)=1.0d0
1578           Ug2(1,1,i-2)=0.0d0
1579           Ug2(1,2,i-2)=0.0d0
1580           Ug2(2,1,i-2)=0.0d0
1581           Ug2(2,2,i-2)=0.0d0
1582         endif
1583         if (i .gt. 3 .and. i .lt. nres+1) then
1584           obrot_der(1,i-2)=-sin1
1585           obrot_der(2,i-2)= cos1
1586           Ugder(1,1,i-2)= sin1
1587           Ugder(1,2,i-2)=-cos1
1588           Ugder(2,1,i-2)=-cos1
1589           Ugder(2,2,i-2)=-sin1
1590           dwacos2=cos2+cos2
1591           dwasin2=sin2+sin2
1592           obrot2_der(1,i-2)=-dwasin2
1593           obrot2_der(2,i-2)= dwacos2
1594           Ug2der(1,1,i-2)= dwasin2
1595           Ug2der(1,2,i-2)=-dwacos2
1596           Ug2der(2,1,i-2)=-dwacos2
1597           Ug2der(2,2,i-2)=-dwasin2
1598         else
1599           obrot_der(1,i-2)=0.0d0
1600           obrot_der(2,i-2)=0.0d0
1601           Ugder(1,1,i-2)=0.0d0
1602           Ugder(1,2,i-2)=0.0d0
1603           Ugder(2,1,i-2)=0.0d0
1604           Ugder(2,2,i-2)=0.0d0
1605           obrot2_der(1,i-2)=0.0d0
1606           obrot2_der(2,i-2)=0.0d0
1607           Ug2der(1,1,i-2)=0.0d0
1608           Ug2der(1,2,i-2)=0.0d0
1609           Ug2der(2,1,i-2)=0.0d0
1610           Ug2der(2,2,i-2)=0.0d0
1611         endif
1612         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1613           if (itype(i-2).le.ntyp) then
1614             iti = itortyp(itype(i-2))
1615           else
1616             iti=ntortyp+1
1617           endif
1618         else
1619           iti=ntortyp+1
1620         endif
1621         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1622           if (itype(i-1).le.ntyp) then
1623             iti1 = itortyp(itype(i-1))
1624           else
1625             iti1=ntortyp+1
1626           endif
1627         else
1628           iti1=ntortyp+1
1629         endif
1630 cd        write (iout,*) '*******i',i,' iti1',iti
1631 cd        write (iout,*) 'b1',b1(:,iti)
1632 cd        write (iout,*) 'b2',b2(:,iti)
1633 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1634 c        print *,"itilde1 i iti iti1",i,iti,iti1
1635         if (i .gt. iatel_s+2) then
1636           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1637           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1638           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1639           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1640           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1641           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1642           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1643         else
1644           do k=1,2
1645             Ub2(k,i-2)=0.0d0
1646             Ctobr(k,i-2)=0.0d0
1647             Dtobr2(k,i-2)=0.0d0
1648             do l=1,2
1649               EUg(l,k,i-2)=0.0d0
1650               CUg(l,k,i-2)=0.0d0
1651               DUg(l,k,i-2)=0.0d0
1652               DtUg2(l,k,i-2)=0.0d0
1653             enddo
1654           enddo
1655         endif
1656 c        print *,"itilde2 i iti iti1",i,iti,iti1
1657         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1658         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1659         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1660         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1661         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1662         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1663         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1664 c        print *,"itilde3 i iti iti1",i,iti,iti1
1665         do k=1,2
1666           muder(k,i-2)=Ub2der(k,i-2)
1667         enddo
1668         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1669           if (itype(i-1).le.ntyp) then
1670             iti1 = itortyp(itype(i-1))
1671           else
1672             iti1=ntortyp+1
1673           endif
1674         else
1675           iti1=ntortyp+1
1676         endif
1677         do k=1,2
1678           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1679         enddo
1680 C Vectors and matrices dependent on a single virtual-bond dihedral.
1681         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1682         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1683         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1684         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1685         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1686         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1687         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1688         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1689         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1690 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1691 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1692       enddo
1693 C Matrices dependent on two consecutive virtual-bond dihedrals.
1694 C The order of matrices is from left to right.
1695       do i=2,nres-1
1696         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1697         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1698         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1699         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1700         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1701         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1702         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1703         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1704       enddo
1705 cd      do i=1,nres
1706 cd        iti = itortyp(itype(i))
1707 cd        write (iout,*) i
1708 cd        do j=1,2
1709 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1710 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1711 cd        enddo
1712 cd      enddo
1713       return
1714       end
1715 C--------------------------------------------------------------------------
1716       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1717 C
1718 C This subroutine calculates the average interaction energy and its gradient
1719 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1720 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1721 C The potential depends both on the distance of peptide-group centers and on
1722 C the orientation of the CA-CA virtual bonds.
1723 C
1724       implicit real*8 (a-h,o-z)
1725       include 'DIMENSIONS'
1726       include 'sizesclu.dat'
1727       include 'COMMON.CONTROL'
1728       include 'COMMON.IOUNITS'
1729       include 'COMMON.GEO'
1730       include 'COMMON.VAR'
1731       include 'COMMON.LOCAL'
1732       include 'COMMON.CHAIN'
1733       include 'COMMON.DERIV'
1734       include 'COMMON.INTERACT'
1735       include 'COMMON.CONTACTS'
1736       include 'COMMON.TORSION'
1737       include 'COMMON.VECTORS'
1738       include 'COMMON.FFIELD'
1739       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1740      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1741       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1742      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1743       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1744 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1745       double precision scal_el /0.5d0/
1746 C 12/13/98
1747 C 13-go grudnia roku pamietnego...
1748       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1749      &                   0.0d0,1.0d0,0.0d0,
1750      &                   0.0d0,0.0d0,1.0d0/
1751 cd      write(iout,*) 'In EELEC'
1752 cd      do i=1,nloctyp
1753 cd        write(iout,*) 'Type',i
1754 cd        write(iout,*) 'B1',B1(:,i)
1755 cd        write(iout,*) 'B2',B2(:,i)
1756 cd        write(iout,*) 'CC',CC(:,:,i)
1757 cd        write(iout,*) 'DD',DD(:,:,i)
1758 cd        write(iout,*) 'EE',EE(:,:,i)
1759 cd      enddo
1760 cd      call check_vecgrad
1761 cd      stop
1762       if (icheckgrad.eq.1) then
1763         do i=1,nres-1
1764           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1765           do k=1,3
1766             dc_norm(k,i)=dc(k,i)*fac
1767           enddo
1768 c          write (iout,*) 'i',i,' fac',fac
1769         enddo
1770       endif
1771       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1772      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1773      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1774 cd      if (wel_loc.gt.0.0d0) then
1775         if (icheckgrad.eq.1) then
1776         call vec_and_deriv_test
1777         else
1778         call vec_and_deriv
1779         endif
1780         call set_matrices
1781       endif
1782 cd      do i=1,nres-1
1783 cd        write (iout,*) 'i=',i
1784 cd        do k=1,3
1785 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1786 cd        enddo
1787 cd        do k=1,3
1788 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1789 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1790 cd        enddo
1791 cd      enddo
1792       num_conti_hb=0
1793       ees=0.0D0
1794       evdw1=0.0D0
1795       eel_loc=0.0d0
1796       eello_turn3=0.0d0
1797       eello_turn4=0.0d0
1798       ind=0
1799       do i=1,nres
1800         num_cont_hb(i)=0
1801       enddo
1802 cd      print '(a)','Enter EELEC'
1803 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1804       do i=1,nres
1805         gel_loc_loc(i)=0.0d0
1806         gcorr_loc(i)=0.0d0
1807       enddo
1808       do i=iatel_s,iatel_e
1809         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
1810         if (itel(i).eq.0) goto 1215
1811         dxi=dc(1,i)
1812         dyi=dc(2,i)
1813         dzi=dc(3,i)
1814         dx_normi=dc_norm(1,i)
1815         dy_normi=dc_norm(2,i)
1816         dz_normi=dc_norm(3,i)
1817         xmedi=c(1,i)+0.5d0*dxi
1818         ymedi=c(2,i)+0.5d0*dyi
1819         zmedi=c(3,i)+0.5d0*dzi
1820         num_conti=0
1821 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1822         do j=ielstart(i),ielend(i)
1823           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
1824           if (itel(j).eq.0) goto 1216
1825           ind=ind+1
1826           iteli=itel(i)
1827           itelj=itel(j)
1828           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1829           aaa=app(iteli,itelj)
1830           bbb=bpp(iteli,itelj)
1831 C Diagnostics only!!!
1832 c         aaa=0.0D0
1833 c         bbb=0.0D0
1834 c         ael6i=0.0D0
1835 c         ael3i=0.0D0
1836 C End diagnostics
1837           ael6i=ael6(iteli,itelj)
1838           ael3i=ael3(iteli,itelj)
1839           dxj=dc(1,j)
1840           dyj=dc(2,j)
1841           dzj=dc(3,j)
1842           dx_normj=dc_norm(1,j)
1843           dy_normj=dc_norm(2,j)
1844           dz_normj=dc_norm(3,j)
1845           xj=c(1,j)+0.5D0*dxj-xmedi
1846           yj=c(2,j)+0.5D0*dyj-ymedi
1847           zj=c(3,j)+0.5D0*dzj-zmedi
1848           rij=xj*xj+yj*yj+zj*zj
1849           rrmij=1.0D0/rij
1850           rij=dsqrt(rij)
1851           rmij=1.0D0/rij
1852           r3ij=rrmij*rmij
1853           r6ij=r3ij*r3ij
1854           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1855           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1856           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1857           fac=cosa-3.0D0*cosb*cosg
1858           ev1=aaa*r6ij*r6ij
1859 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1860           if (j.eq.i+2) ev1=scal_el*ev1
1861           ev2=bbb*r6ij
1862           fac3=ael6i*r6ij
1863           fac4=ael3i*r3ij
1864           evdwij=ev1+ev2
1865           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1866           el2=fac4*fac
1867           eesij=el1+el2
1868 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1869 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1870           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1871           ees=ees+eesij
1872           evdw1=evdw1+evdwij
1873 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1874 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1875 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1876 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1877 C
1878 C Calculate contributions to the Cartesian gradient.
1879 C
1880 #ifdef SPLITELE
1881           facvdw=-6*rrmij*(ev1+evdwij)
1882           facel=-3*rrmij*(el1+eesij)
1883           fac1=fac
1884           erij(1)=xj*rmij
1885           erij(2)=yj*rmij
1886           erij(3)=zj*rmij
1887           if (calc_grad) then
1888 *
1889 * Radial derivatives. First process both termini of the fragment (i,j)
1890 *
1891           ggg(1)=facel*xj
1892           ggg(2)=facel*yj
1893           ggg(3)=facel*zj
1894           do k=1,3
1895             ghalf=0.5D0*ggg(k)
1896             gelc(k,i)=gelc(k,i)+ghalf
1897             gelc(k,j)=gelc(k,j)+ghalf
1898           enddo
1899 *
1900 * Loop over residues i+1 thru j-1.
1901 *
1902           do k=i+1,j-1
1903             do l=1,3
1904               gelc(l,k)=gelc(l,k)+ggg(l)
1905             enddo
1906           enddo
1907           ggg(1)=facvdw*xj
1908           ggg(2)=facvdw*yj
1909           ggg(3)=facvdw*zj
1910           do k=1,3
1911             ghalf=0.5D0*ggg(k)
1912             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
1913             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
1914           enddo
1915 *
1916 * Loop over residues i+1 thru j-1.
1917 *
1918           do k=i+1,j-1
1919             do l=1,3
1920               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
1921             enddo
1922           enddo
1923 #else
1924           facvdw=ev1+evdwij
1925           facel=el1+eesij
1926           fac1=fac
1927           fac=-3*rrmij*(facvdw+facvdw+facel)
1928           erij(1)=xj*rmij
1929           erij(2)=yj*rmij
1930           erij(3)=zj*rmij
1931           if (calc_grad) then
1932 *
1933 * Radial derivatives. First process both termini of the fragment (i,j)
1934 *
1935           ggg(1)=fac*xj
1936           ggg(2)=fac*yj
1937           ggg(3)=fac*zj
1938           do k=1,3
1939             ghalf=0.5D0*ggg(k)
1940             gelc(k,i)=gelc(k,i)+ghalf
1941             gelc(k,j)=gelc(k,j)+ghalf
1942           enddo
1943 *
1944 * Loop over residues i+1 thru j-1.
1945 *
1946           do k=i+1,j-1
1947             do l=1,3
1948               gelc(l,k)=gelc(l,k)+ggg(l)
1949             enddo
1950           enddo
1951 #endif
1952 *
1953 * Angular part
1954 *
1955           ecosa=2.0D0*fac3*fac1+fac4
1956           fac4=-3.0D0*fac4
1957           fac3=-6.0D0*fac3
1958           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
1959           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
1960           do k=1,3
1961             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
1962             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
1963           enddo
1964 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
1965 cd   &          (dcosg(k),k=1,3)
1966           do k=1,3
1967             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
1968           enddo
1969           do k=1,3
1970             ghalf=0.5D0*ggg(k)
1971             gelc(k,i)=gelc(k,i)+ghalf
1972      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
1973      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
1974             gelc(k,j)=gelc(k,j)+ghalf
1975      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
1976      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
1977           enddo
1978           do k=i+1,j-1
1979             do l=1,3
1980               gelc(l,k)=gelc(l,k)+ggg(l)
1981             enddo
1982           enddo
1983           endif
1984
1985           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1986      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
1987      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
1988 C
1989 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
1990 C   energy of a peptide unit is assumed in the form of a second-order
1991 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
1992 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
1993 C   are computed for EVERY pair of non-contiguous peptide groups.
1994 C
1995           if (j.lt.nres-1) then
1996             j1=j+1
1997             j2=j-1
1998           else
1999             j1=j-1
2000             j2=j-2
2001           endif
2002           kkk=0
2003           do k=1,2
2004             do l=1,2
2005               kkk=kkk+1
2006               muij(kkk)=mu(k,i)*mu(l,j)
2007             enddo
2008           enddo
2009 cd         write (iout,*) 'EELEC: i',i,' j',j
2010 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2011 cd          write(iout,*) 'muij',muij
2012           ury=scalar(uy(1,i),erij)
2013           urz=scalar(uz(1,i),erij)
2014           vry=scalar(uy(1,j),erij)
2015           vrz=scalar(uz(1,j),erij)
2016           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2017           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2018           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2019           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2020 C For diagnostics only
2021 cd          a22=1.0d0
2022 cd          a23=1.0d0
2023 cd          a32=1.0d0
2024 cd          a33=1.0d0
2025           fac=dsqrt(-ael6i)*r3ij
2026 cd          write (2,*) 'fac=',fac
2027 C For diagnostics only
2028 cd          fac=1.0d0
2029           a22=a22*fac
2030           a23=a23*fac
2031           a32=a32*fac
2032           a33=a33*fac
2033 cd          write (iout,'(4i5,4f10.5)')
2034 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2035 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2036 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2037 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2038 cd          write (iout,'(4f10.5)')
2039 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2040 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2041 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2042 cd           write (iout,'(2i3,9f10.5/)') i,j,
2043 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2044           if (calc_grad) then
2045 C Derivatives of the elements of A in virtual-bond vectors
2046           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2047 cd          do k=1,3
2048 cd            do l=1,3
2049 cd              erder(k,l)=0.0d0
2050 cd            enddo
2051 cd          enddo
2052           do k=1,3
2053             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2054             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2055             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2056             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2057             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2058             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2059             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2060             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2061             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2062             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2063             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2064             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2065           enddo
2066 cd          do k=1,3
2067 cd            do l=1,3
2068 cd              uryg(k,l)=0.0d0
2069 cd              urzg(k,l)=0.0d0
2070 cd              vryg(k,l)=0.0d0
2071 cd              vrzg(k,l)=0.0d0
2072 cd            enddo
2073 cd          enddo
2074 C Compute radial contributions to the gradient
2075           facr=-3.0d0*rrmij
2076           a22der=a22*facr
2077           a23der=a23*facr
2078           a32der=a32*facr
2079           a33der=a33*facr
2080 cd          a22der=0.0d0
2081 cd          a23der=0.0d0
2082 cd          a32der=0.0d0
2083 cd          a33der=0.0d0
2084           agg(1,1)=a22der*xj
2085           agg(2,1)=a22der*yj
2086           agg(3,1)=a22der*zj
2087           agg(1,2)=a23der*xj
2088           agg(2,2)=a23der*yj
2089           agg(3,2)=a23der*zj
2090           agg(1,3)=a32der*xj
2091           agg(2,3)=a32der*yj
2092           agg(3,3)=a32der*zj
2093           agg(1,4)=a33der*xj
2094           agg(2,4)=a33der*yj
2095           agg(3,4)=a33der*zj
2096 C Add the contributions coming from er
2097           fac3=-3.0d0*fac
2098           do k=1,3
2099             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2100             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2101             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2102             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2103           enddo
2104           do k=1,3
2105 C Derivatives in DC(i)
2106             ghalf1=0.5d0*agg(k,1)
2107             ghalf2=0.5d0*agg(k,2)
2108             ghalf3=0.5d0*agg(k,3)
2109             ghalf4=0.5d0*agg(k,4)
2110             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2111      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2112             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2113      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2114             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2115      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2116             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2117      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2118 C Derivatives in DC(i+1)
2119             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2120      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2121             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2122      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2123             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2124      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2125             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2126      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2127 C Derivatives in DC(j)
2128             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2129      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2130             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2131      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2132             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2133      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2134             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2135      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2136 C Derivatives in DC(j+1) or DC(nres-1)
2137             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2138      &      -3.0d0*vryg(k,3)*ury)
2139             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2140      &      -3.0d0*vrzg(k,3)*ury)
2141             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2142      &      -3.0d0*vryg(k,3)*urz)
2143             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2144      &      -3.0d0*vrzg(k,3)*urz)
2145 cd            aggi(k,1)=ghalf1
2146 cd            aggi(k,2)=ghalf2
2147 cd            aggi(k,3)=ghalf3
2148 cd            aggi(k,4)=ghalf4
2149 C Derivatives in DC(i+1)
2150 cd            aggi1(k,1)=agg(k,1)
2151 cd            aggi1(k,2)=agg(k,2)
2152 cd            aggi1(k,3)=agg(k,3)
2153 cd            aggi1(k,4)=agg(k,4)
2154 C Derivatives in DC(j)
2155 cd            aggj(k,1)=ghalf1
2156 cd            aggj(k,2)=ghalf2
2157 cd            aggj(k,3)=ghalf3
2158 cd            aggj(k,4)=ghalf4
2159 C Derivatives in DC(j+1)
2160 cd            aggj1(k,1)=0.0d0
2161 cd            aggj1(k,2)=0.0d0
2162 cd            aggj1(k,3)=0.0d0
2163 cd            aggj1(k,4)=0.0d0
2164             if (j.eq.nres-1 .and. i.lt.j-2) then
2165               do l=1,4
2166                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2167 cd                aggj1(k,l)=agg(k,l)
2168               enddo
2169             endif
2170           enddo
2171           endif
2172 c          goto 11111
2173 C Check the loc-el terms by numerical integration
2174           acipa(1,1)=a22
2175           acipa(1,2)=a23
2176           acipa(2,1)=a32
2177           acipa(2,2)=a33
2178           a22=-a22
2179           a23=-a23
2180           do l=1,2
2181             do k=1,3
2182               agg(k,l)=-agg(k,l)
2183               aggi(k,l)=-aggi(k,l)
2184               aggi1(k,l)=-aggi1(k,l)
2185               aggj(k,l)=-aggj(k,l)
2186               aggj1(k,l)=-aggj1(k,l)
2187             enddo
2188           enddo
2189           if (j.lt.nres-1) then
2190             a22=-a22
2191             a32=-a32
2192             do l=1,3,2
2193               do k=1,3
2194                 agg(k,l)=-agg(k,l)
2195                 aggi(k,l)=-aggi(k,l)
2196                 aggi1(k,l)=-aggi1(k,l)
2197                 aggj(k,l)=-aggj(k,l)
2198                 aggj1(k,l)=-aggj1(k,l)
2199               enddo
2200             enddo
2201           else
2202             a22=-a22
2203             a23=-a23
2204             a32=-a32
2205             a33=-a33
2206             do l=1,4
2207               do k=1,3
2208                 agg(k,l)=-agg(k,l)
2209                 aggi(k,l)=-aggi(k,l)
2210                 aggi1(k,l)=-aggi1(k,l)
2211                 aggj(k,l)=-aggj(k,l)
2212                 aggj1(k,l)=-aggj1(k,l)
2213               enddo
2214             enddo
2215           endif
2216           ENDIF ! WCORR
2217 11111     continue
2218           IF (wel_loc.gt.0.0d0) THEN
2219 C Contribution to the local-electrostatic energy coming from the i-j pair
2220           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2221      &     +a33*muij(4)
2222 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2223 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2224           eel_loc=eel_loc+eel_loc_ij
2225 C Partial derivatives in virtual-bond dihedral angles gamma
2226           if (calc_grad) then
2227           if (i.gt.1)
2228      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2229      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2230      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2231           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2232      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2233      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2234 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2235 cd          write(iout,*) 'agg  ',agg
2236 cd          write(iout,*) 'aggi ',aggi
2237 cd          write(iout,*) 'aggi1',aggi1
2238 cd          write(iout,*) 'aggj ',aggj
2239 cd          write(iout,*) 'aggj1',aggj1
2240
2241 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2242           do l=1,3
2243             ggg(l)=agg(l,1)*muij(1)+
2244      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2245           enddo
2246           do k=i+2,j2
2247             do l=1,3
2248               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2249             enddo
2250           enddo
2251 C Remaining derivatives of eello
2252           do l=1,3
2253             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2254      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2255             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2256      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2257             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2258      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2259             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2260      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2261           enddo
2262           endif
2263           ENDIF
2264           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2265 C Contributions from turns
2266             a_temp(1,1)=a22
2267             a_temp(1,2)=a23
2268             a_temp(2,1)=a32
2269             a_temp(2,2)=a33
2270             call eturn34(i,j,eello_turn3,eello_turn4)
2271           endif
2272 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2273           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2274 C
2275 C Calculate the contact function. The ith column of the array JCONT will
2276 C contain the numbers of atoms that make contacts with the atom I (of numbers
2277 C greater than I). The arrays FACONT and GACONT will contain the values of
2278 C the contact function and its derivative.
2279 c           r0ij=1.02D0*rpp(iteli,itelj)
2280 c           r0ij=1.11D0*rpp(iteli,itelj)
2281             r0ij=2.20D0*rpp(iteli,itelj)
2282 c           r0ij=1.55D0*rpp(iteli,itelj)
2283             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2284             if (fcont.gt.0.0D0) then
2285               num_conti=num_conti+1
2286               if (num_conti.gt.maxconts) then
2287                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2288      &                         ' will skip next contacts for this conf.'
2289               else
2290                 jcont_hb(num_conti,i)=j
2291                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2292      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2293 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2294 C  terms.
2295                 d_cont(num_conti,i)=rij
2296 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2297 C     --- Electrostatic-interaction matrix ---
2298                 a_chuj(1,1,num_conti,i)=a22
2299                 a_chuj(1,2,num_conti,i)=a23
2300                 a_chuj(2,1,num_conti,i)=a32
2301                 a_chuj(2,2,num_conti,i)=a33
2302 C     --- Gradient of rij
2303                 do kkk=1,3
2304                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2305                 enddo
2306 c             if (i.eq.1) then
2307 c                a_chuj(1,1,num_conti,i)=-0.61d0
2308 c                a_chuj(1,2,num_conti,i)= 0.4d0
2309 c                a_chuj(2,1,num_conti,i)= 0.65d0
2310 c                a_chuj(2,2,num_conti,i)= 0.50d0
2311 c             else if (i.eq.2) then
2312 c                a_chuj(1,1,num_conti,i)= 0.0d0
2313 c                a_chuj(1,2,num_conti,i)= 0.0d0
2314 c                a_chuj(2,1,num_conti,i)= 0.0d0
2315 c                a_chuj(2,2,num_conti,i)= 0.0d0
2316 c             endif
2317 C     --- and its gradients
2318 cd                write (iout,*) 'i',i,' j',j
2319 cd                do kkk=1,3
2320 cd                write (iout,*) 'iii 1 kkk',kkk
2321 cd                write (iout,*) agg(kkk,:)
2322 cd                enddo
2323 cd                do kkk=1,3
2324 cd                write (iout,*) 'iii 2 kkk',kkk
2325 cd                write (iout,*) aggi(kkk,:)
2326 cd                enddo
2327 cd                do kkk=1,3
2328 cd                write (iout,*) 'iii 3 kkk',kkk
2329 cd                write (iout,*) aggi1(kkk,:)
2330 cd                enddo
2331 cd                do kkk=1,3
2332 cd                write (iout,*) 'iii 4 kkk',kkk
2333 cd                write (iout,*) aggj(kkk,:)
2334 cd                enddo
2335 cd                do kkk=1,3
2336 cd                write (iout,*) 'iii 5 kkk',kkk
2337 cd                write (iout,*) aggj1(kkk,:)
2338 cd                enddo
2339                 kkll=0
2340                 do k=1,2
2341                   do l=1,2
2342                     kkll=kkll+1
2343                     do m=1,3
2344                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2345                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2346                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2347                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2348                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2349 c                      do mm=1,5
2350 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2351 c                      enddo
2352                     enddo
2353                   enddo
2354                 enddo
2355                 ENDIF
2356                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2357 C Calculate contact energies
2358                 cosa4=4.0D0*cosa
2359                 wij=cosa-3.0D0*cosb*cosg
2360                 cosbg1=cosb+cosg
2361                 cosbg2=cosb-cosg
2362 c               fac3=dsqrt(-ael6i)/r0ij**3
2363                 fac3=dsqrt(-ael6i)*r3ij
2364                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2365                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2366 c               ees0mij=0.0D0
2367                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2368                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2369 C Diagnostics. Comment out or remove after debugging!
2370 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2371 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2372 c               ees0m(num_conti,i)=0.0D0
2373 C End diagnostics.
2374 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2375 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2376                 facont_hb(num_conti,i)=fcont
2377                 if (calc_grad) then
2378 C Angular derivatives of the contact function
2379                 ees0pij1=fac3/ees0pij
2380                 ees0mij1=fac3/ees0mij
2381                 fac3p=-3.0D0*fac3*rrmij
2382                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2383                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2384 c               ees0mij1=0.0D0
2385                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2386                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2387                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2388                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2389                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2390                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2391                 ecosap=ecosa1+ecosa2
2392                 ecosbp=ecosb1+ecosb2
2393                 ecosgp=ecosg1+ecosg2
2394                 ecosam=ecosa1-ecosa2
2395                 ecosbm=ecosb1-ecosb2
2396                 ecosgm=ecosg1-ecosg2
2397 C Diagnostics
2398 c               ecosap=ecosa1
2399 c               ecosbp=ecosb1
2400 c               ecosgp=ecosg1
2401 c               ecosam=0.0D0
2402 c               ecosbm=0.0D0
2403 c               ecosgm=0.0D0
2404 C End diagnostics
2405                 fprimcont=fprimcont/rij
2406 cd              facont_hb(num_conti,i)=1.0D0
2407 C Following line is for diagnostics.
2408 cd              fprimcont=0.0D0
2409                 do k=1,3
2410                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2411                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2412                 enddo
2413                 do k=1,3
2414                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2415                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2416                 enddo
2417                 gggp(1)=gggp(1)+ees0pijp*xj
2418                 gggp(2)=gggp(2)+ees0pijp*yj
2419                 gggp(3)=gggp(3)+ees0pijp*zj
2420                 gggm(1)=gggm(1)+ees0mijp*xj
2421                 gggm(2)=gggm(2)+ees0mijp*yj
2422                 gggm(3)=gggm(3)+ees0mijp*zj
2423 C Derivatives due to the contact function
2424                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2425                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2426                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2427                 do k=1,3
2428                   ghalfp=0.5D0*gggp(k)
2429                   ghalfm=0.5D0*gggm(k)
2430                   gacontp_hb1(k,num_conti,i)=ghalfp
2431      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2432      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2433                   gacontp_hb2(k,num_conti,i)=ghalfp
2434      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2435      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2436                   gacontp_hb3(k,num_conti,i)=gggp(k)
2437                   gacontm_hb1(k,num_conti,i)=ghalfm
2438      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2439      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2440                   gacontm_hb2(k,num_conti,i)=ghalfm
2441      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2442      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2443                   gacontm_hb3(k,num_conti,i)=gggm(k)
2444                 enddo
2445                 endif
2446 C Diagnostics. Comment out or remove after debugging!
2447 cdiag           do k=1,3
2448 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2449 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2450 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2451 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2452 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2453 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2454 cdiag           enddo
2455               ENDIF ! wcorr
2456               endif  ! num_conti.le.maxconts
2457             endif  ! fcont.gt.0
2458           endif    ! j.gt.i+1
2459  1216     continue
2460         enddo ! j
2461         num_cont_hb(i)=num_conti
2462  1215   continue
2463       enddo   ! i
2464 cd      do i=1,nres
2465 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2466 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2467 cd      enddo
2468 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2469 ccc      eel_loc=eel_loc+eello_turn3
2470       return
2471       end
2472 C-----------------------------------------------------------------------------
2473       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2474 C Third- and fourth-order contributions from turns
2475       implicit real*8 (a-h,o-z)
2476       include 'DIMENSIONS'
2477       include 'sizesclu.dat'
2478       include 'COMMON.IOUNITS'
2479       include 'COMMON.GEO'
2480       include 'COMMON.VAR'
2481       include 'COMMON.LOCAL'
2482       include 'COMMON.CHAIN'
2483       include 'COMMON.DERIV'
2484       include 'COMMON.INTERACT'
2485       include 'COMMON.CONTACTS'
2486       include 'COMMON.TORSION'
2487       include 'COMMON.VECTORS'
2488       include 'COMMON.FFIELD'
2489       dimension ggg(3)
2490       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2491      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2492      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2493       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2494      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2495       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2496       if (j.eq.i+2) then
2497 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2498 C
2499 C               Third-order contributions
2500 C
2501 C                 (i+2)o----(i+3)
2502 C                      | |
2503 C                      | |
2504 C                 (i+1)o----i
2505 C
2506 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2507 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2508         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2509         call transpose2(auxmat(1,1),auxmat1(1,1))
2510         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2511         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2512 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2513 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2514 cd     &    ' eello_turn3_num',4*eello_turn3_num
2515         if (calc_grad) then
2516 C Derivatives in gamma(i)
2517         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2518         call transpose2(auxmat2(1,1),pizda(1,1))
2519         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2520         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2521 C Derivatives in gamma(i+1)
2522         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2523         call transpose2(auxmat2(1,1),pizda(1,1))
2524         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2525         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2526      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2527 C Cartesian derivatives
2528         do l=1,3
2529           a_temp(1,1)=aggi(l,1)
2530           a_temp(1,2)=aggi(l,2)
2531           a_temp(2,1)=aggi(l,3)
2532           a_temp(2,2)=aggi(l,4)
2533           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2534           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2535      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2536           a_temp(1,1)=aggi1(l,1)
2537           a_temp(1,2)=aggi1(l,2)
2538           a_temp(2,1)=aggi1(l,3)
2539           a_temp(2,2)=aggi1(l,4)
2540           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2541           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2542      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2543           a_temp(1,1)=aggj(l,1)
2544           a_temp(1,2)=aggj(l,2)
2545           a_temp(2,1)=aggj(l,3)
2546           a_temp(2,2)=aggj(l,4)
2547           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2548           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2549      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2550           a_temp(1,1)=aggj1(l,1)
2551           a_temp(1,2)=aggj1(l,2)
2552           a_temp(2,1)=aggj1(l,3)
2553           a_temp(2,2)=aggj1(l,4)
2554           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2555           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2556      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2557         enddo
2558         endif
2559       else if (j.eq.i+3 .and. itype(i+2).ne.21) then
2560 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2561 C
2562 C               Fourth-order contributions
2563 C
2564 C                 (i+3)o----(i+4)
2565 C                     /  |
2566 C               (i+2)o   |
2567 C                     \  |
2568 C                 (i+1)o----i
2569 C
2570 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2571 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2572         iti1=itortyp(itype(i+1))
2573         iti2=itortyp(itype(i+2))
2574         iti3=itortyp(itype(i+3))
2575         call transpose2(EUg(1,1,i+1),e1t(1,1))
2576         call transpose2(Eug(1,1,i+2),e2t(1,1))
2577         call transpose2(Eug(1,1,i+3),e3t(1,1))
2578         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2579         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2580         s1=scalar2(b1(1,iti2),auxvec(1))
2581         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2582         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2583         s2=scalar2(b1(1,iti1),auxvec(1))
2584         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2585         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2586         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2587         eello_turn4=eello_turn4-(s1+s2+s3)
2588 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2589 cd     &    ' eello_turn4_num',8*eello_turn4_num
2590 C Derivatives in gamma(i)
2591         if (calc_grad) then
2592         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2593         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2594         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2595         s1=scalar2(b1(1,iti2),auxvec(1))
2596         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2597         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2598         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2599 C Derivatives in gamma(i+1)
2600         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2601         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2602         s2=scalar2(b1(1,iti1),auxvec(1))
2603         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2604         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2605         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2606         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2607 C Derivatives in gamma(i+2)
2608         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2609         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2610         s1=scalar2(b1(1,iti2),auxvec(1))
2611         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2612         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2613         s2=scalar2(b1(1,iti1),auxvec(1))
2614         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2615         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2616         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2617         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2618 C Cartesian derivatives
2619 C Derivatives of this turn contributions in DC(i+2)
2620         if (j.lt.nres-1) then
2621           do l=1,3
2622             a_temp(1,1)=agg(l,1)
2623             a_temp(1,2)=agg(l,2)
2624             a_temp(2,1)=agg(l,3)
2625             a_temp(2,2)=agg(l,4)
2626             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2627             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2628             s1=scalar2(b1(1,iti2),auxvec(1))
2629             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2630             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2631             s2=scalar2(b1(1,iti1),auxvec(1))
2632             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2633             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2634             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2635             ggg(l)=-(s1+s2+s3)
2636             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2637           enddo
2638         endif
2639 C Remaining derivatives of this turn contribution
2640         do l=1,3
2641           a_temp(1,1)=aggi(l,1)
2642           a_temp(1,2)=aggi(l,2)
2643           a_temp(2,1)=aggi(l,3)
2644           a_temp(2,2)=aggi(l,4)
2645           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2646           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2647           s1=scalar2(b1(1,iti2),auxvec(1))
2648           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2649           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2650           s2=scalar2(b1(1,iti1),auxvec(1))
2651           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2652           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2653           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2654           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2655           a_temp(1,1)=aggi1(l,1)
2656           a_temp(1,2)=aggi1(l,2)
2657           a_temp(2,1)=aggi1(l,3)
2658           a_temp(2,2)=aggi1(l,4)
2659           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2660           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2661           s1=scalar2(b1(1,iti2),auxvec(1))
2662           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2663           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2664           s2=scalar2(b1(1,iti1),auxvec(1))
2665           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2666           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2667           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2668           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2669           a_temp(1,1)=aggj(l,1)
2670           a_temp(1,2)=aggj(l,2)
2671           a_temp(2,1)=aggj(l,3)
2672           a_temp(2,2)=aggj(l,4)
2673           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2674           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2675           s1=scalar2(b1(1,iti2),auxvec(1))
2676           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2677           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2678           s2=scalar2(b1(1,iti1),auxvec(1))
2679           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2680           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2681           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2682           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2683           a_temp(1,1)=aggj1(l,1)
2684           a_temp(1,2)=aggj1(l,2)
2685           a_temp(2,1)=aggj1(l,3)
2686           a_temp(2,2)=aggj1(l,4)
2687           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2688           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2689           s1=scalar2(b1(1,iti2),auxvec(1))
2690           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2691           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2692           s2=scalar2(b1(1,iti1),auxvec(1))
2693           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2694           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2695           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2696           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2697         enddo
2698         endif
2699       endif
2700       return
2701       end
2702 C-----------------------------------------------------------------------------
2703       subroutine vecpr(u,v,w)
2704       implicit real*8(a-h,o-z)
2705       dimension u(3),v(3),w(3)
2706       w(1)=u(2)*v(3)-u(3)*v(2)
2707       w(2)=-u(1)*v(3)+u(3)*v(1)
2708       w(3)=u(1)*v(2)-u(2)*v(1)
2709       return
2710       end
2711 C-----------------------------------------------------------------------------
2712       subroutine unormderiv(u,ugrad,unorm,ungrad)
2713 C This subroutine computes the derivatives of a normalized vector u, given
2714 C the derivatives computed without normalization conditions, ugrad. Returns
2715 C ungrad.
2716       implicit none
2717       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2718       double precision vec(3)
2719       double precision scalar
2720       integer i,j
2721 c      write (2,*) 'ugrad',ugrad
2722 c      write (2,*) 'u',u
2723       do i=1,3
2724         vec(i)=scalar(ugrad(1,i),u(1))
2725       enddo
2726 c      write (2,*) 'vec',vec
2727       do i=1,3
2728         do j=1,3
2729           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2730         enddo
2731       enddo
2732 c      write (2,*) 'ungrad',ungrad
2733       return
2734       end
2735 C-----------------------------------------------------------------------------
2736       subroutine escp(evdw2,evdw2_14)
2737 C
2738 C This subroutine calculates the excluded-volume interaction energy between
2739 C peptide-group centers and side chains and its gradient in virtual-bond and
2740 C side-chain vectors.
2741 C
2742       implicit real*8 (a-h,o-z)
2743       include 'DIMENSIONS'
2744       include 'sizesclu.dat'
2745       include 'COMMON.GEO'
2746       include 'COMMON.VAR'
2747       include 'COMMON.LOCAL'
2748       include 'COMMON.CHAIN'
2749       include 'COMMON.DERIV'
2750       include 'COMMON.INTERACT'
2751       include 'COMMON.FFIELD'
2752       include 'COMMON.IOUNITS'
2753       dimension ggg(3)
2754       evdw2=0.0D0
2755       evdw2_14=0.0d0
2756 cd    print '(a)','Enter ESCP'
2757 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2758 c     &  ' scal14',scal14
2759       do i=iatscp_s,iatscp_e
2760         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
2761         iteli=itel(i)
2762 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2763 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2764         if (iteli.eq.0) goto 1225
2765         xi=0.5D0*(c(1,i)+c(1,i+1))
2766         yi=0.5D0*(c(2,i)+c(2,i+1))
2767         zi=0.5D0*(c(3,i)+c(3,i+1))
2768
2769         do iint=1,nscp_gr(i)
2770
2771         do j=iscpstart(i,iint),iscpend(i,iint)
2772           itypj=itype(j)
2773           if (itypj.eq.21) cycle
2774 C Uncomment following three lines for SC-p interactions
2775 c         xj=c(1,nres+j)-xi
2776 c         yj=c(2,nres+j)-yi
2777 c         zj=c(3,nres+j)-zi
2778 C Uncomment following three lines for Ca-p interactions
2779           xj=c(1,j)-xi
2780           yj=c(2,j)-yi
2781           zj=c(3,j)-zi
2782           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2783           fac=rrij**expon2
2784           e1=fac*fac*aad(itypj,iteli)
2785           e2=fac*bad(itypj,iteli)
2786           if (iabs(j-i) .le. 2) then
2787             e1=scal14*e1
2788             e2=scal14*e2
2789             evdw2_14=evdw2_14+e1+e2
2790           endif
2791           evdwij=e1+e2
2792 c          write (iout,*) i,j,evdwij
2793           evdw2=evdw2+evdwij
2794           if (calc_grad) then
2795 C
2796 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2797 C
2798           fac=-(evdwij+e1)*rrij
2799           ggg(1)=xj*fac
2800           ggg(2)=yj*fac
2801           ggg(3)=zj*fac
2802           if (j.lt.i) then
2803 cd          write (iout,*) 'j<i'
2804 C Uncomment following three lines for SC-p interactions
2805 c           do k=1,3
2806 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2807 c           enddo
2808           else
2809 cd          write (iout,*) 'j>i'
2810             do k=1,3
2811               ggg(k)=-ggg(k)
2812 C Uncomment following line for SC-p interactions
2813 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2814             enddo
2815           endif
2816           do k=1,3
2817             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2818           enddo
2819           kstart=min0(i+1,j)
2820           kend=max0(i-1,j-1)
2821 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2822 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2823           do k=kstart,kend
2824             do l=1,3
2825               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2826             enddo
2827           enddo
2828           endif
2829         enddo
2830         enddo ! iint
2831  1225   continue
2832       enddo ! i
2833       do i=1,nct
2834         do j=1,3
2835           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2836           gradx_scp(j,i)=expon*gradx_scp(j,i)
2837         enddo
2838       enddo
2839 C******************************************************************************
2840 C
2841 C                              N O T E !!!
2842 C
2843 C To save time the factor EXPON has been extracted from ALL components
2844 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2845 C use!
2846 C
2847 C******************************************************************************
2848       return
2849       end
2850 C--------------------------------------------------------------------------
2851       subroutine edis(ehpb)
2852 C
2853 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2854 C
2855       implicit real*8 (a-h,o-z)
2856       include 'DIMENSIONS'
2857       include 'sizesclu.dat'
2858       include 'COMMON.SBRIDGE'
2859       include 'COMMON.CHAIN'
2860       include 'COMMON.DERIV'
2861       include 'COMMON.VAR'
2862       include 'COMMON.INTERACT'
2863       dimension ggg(3)
2864       ehpb=0.0D0
2865 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
2866 cd    print *,'link_start=',link_start,' link_end=',link_end
2867       if (link_end.eq.0) return
2868       do i=link_start,link_end
2869 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2870 C CA-CA distance used in regularization of structure.
2871         ii=ihpb(i)
2872         jj=jhpb(i)
2873 C iii and jjj point to the residues for which the distance is assigned.
2874         if (ii.gt.nres) then
2875           iii=ii-nres
2876           jjj=jj-nres
2877         else
2878           iii=ii
2879           jjj=jj
2880         endif
2881 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2882 C    distance and angle dependent SS bond potential.
2883         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2884           call ssbond_ene(iii,jjj,eij)
2885           ehpb=ehpb+2*eij
2886         else
2887 C Calculate the distance between the two points and its difference from the
2888 C target distance.
2889         dd=dist(ii,jj)
2890         rdis=dd-dhpb(i)
2891 C Get the force constant corresponding to this distance.
2892         waga=forcon(i)
2893 C Calculate the contribution to energy.
2894         ehpb=ehpb+waga*rdis*rdis
2895 C
2896 C Evaluate gradient.
2897 C
2898         fac=waga*rdis/dd
2899 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
2900 cd   &   ' waga=',waga,' fac=',fac
2901         do j=1,3
2902           ggg(j)=fac*(c(j,jj)-c(j,ii))
2903         enddo
2904 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
2905 C If this is a SC-SC distance, we need to calculate the contributions to the
2906 C Cartesian gradient in the SC vectors (ghpbx).
2907         if (iii.lt.ii) then
2908           do j=1,3
2909             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2910             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2911           enddo
2912         endif
2913         do j=iii,jjj-1
2914           do k=1,3
2915             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
2916           enddo
2917         enddo
2918         endif
2919       enddo
2920       ehpb=0.5D0*ehpb
2921       return
2922       end
2923 C--------------------------------------------------------------------------
2924       subroutine ssbond_ene(i,j,eij)
2925 C
2926 C Calculate the distance and angle dependent SS-bond potential energy
2927 C using a free-energy function derived based on RHF/6-31G** ab initio
2928 C calculations of diethyl disulfide.
2929 C
2930 C A. Liwo and U. Kozlowska, 11/24/03
2931 C
2932       implicit real*8 (a-h,o-z)
2933       include 'DIMENSIONS'
2934       include 'sizesclu.dat'
2935       include 'COMMON.SBRIDGE'
2936       include 'COMMON.CHAIN'
2937       include 'COMMON.DERIV'
2938       include 'COMMON.LOCAL'
2939       include 'COMMON.INTERACT'
2940       include 'COMMON.VAR'
2941       include 'COMMON.IOUNITS'
2942       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
2943       itypi=itype(i)
2944       xi=c(1,nres+i)
2945       yi=c(2,nres+i)
2946       zi=c(3,nres+i)
2947       dxi=dc_norm(1,nres+i)
2948       dyi=dc_norm(2,nres+i)
2949       dzi=dc_norm(3,nres+i)
2950       dsci_inv=dsc_inv(itypi)
2951       itypj=itype(j)
2952       dscj_inv=dsc_inv(itypj)
2953       xj=c(1,nres+j)-xi
2954       yj=c(2,nres+j)-yi
2955       zj=c(3,nres+j)-zi
2956       dxj=dc_norm(1,nres+j)
2957       dyj=dc_norm(2,nres+j)
2958       dzj=dc_norm(3,nres+j)
2959       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2960       rij=dsqrt(rrij)
2961       erij(1)=xj*rij
2962       erij(2)=yj*rij
2963       erij(3)=zj*rij
2964       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2965       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2966       om12=dxi*dxj+dyi*dyj+dzi*dzj
2967       do k=1,3
2968         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2969         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2970       enddo
2971       rij=1.0d0/rij
2972       deltad=rij-d0cm
2973       deltat1=1.0d0-om1
2974       deltat2=1.0d0+om2
2975       deltat12=om2-om1+2.0d0
2976       cosphi=om12-om1*om2
2977       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
2978      &  +akct*deltad*deltat12
2979      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
2980 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
2981 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
2982 c     &  " deltat12",deltat12," eij",eij
2983       ed=2*akcm*deltad+akct*deltat12
2984       pom1=akct*deltad
2985       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
2986       eom1=-2*akth*deltat1-pom1-om2*pom2
2987       eom2= 2*akth*deltat2+pom1-om1*pom2
2988       eom12=pom2
2989       do k=1,3
2990         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2991       enddo
2992       do k=1,3
2993         ghpbx(k,i)=ghpbx(k,i)-gg(k)
2994      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
2995         ghpbx(k,j)=ghpbx(k,j)+gg(k)
2996      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
2997       enddo
2998 C
2999 C Calculate the components of the gradient in DC and X
3000 C
3001       do k=i,j-1
3002         do l=1,3
3003           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3004         enddo
3005       enddo
3006       return
3007       end
3008 C--------------------------------------------------------------------------
3009       subroutine ebond(estr)
3010 c
3011 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3012 c
3013       implicit real*8 (a-h,o-z)
3014       include 'DIMENSIONS'
3015       include 'sizesclu.dat'
3016       include 'COMMON.LOCAL'
3017       include 'COMMON.GEO'
3018       include 'COMMON.INTERACT'
3019       include 'COMMON.DERIV'
3020       include 'COMMON.VAR'
3021       include 'COMMON.CHAIN'
3022       include 'COMMON.IOUNITS'
3023       include 'COMMON.NAMES'
3024       include 'COMMON.FFIELD'
3025       include 'COMMON.CONTROL'
3026       logical energy_dec /.false./
3027       double precision u(3),ud(3)
3028       estr=0.0d0
3029       do i=nnt+1,nct
3030         if (itype(i-1).eq.21 .or. itype(i).eq.21) then
3031           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
3032           do j=1,3
3033           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
3034      &      *dc(j,i-1)/vbld(i)
3035           enddo
3036           if (energy_dec) write(iout,*)
3037      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
3038         else
3039           diff = vbld(i)-vbldp0
3040 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3041           estr=estr+diff*diff
3042           do j=1,3
3043             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3044           enddo
3045         endif
3046
3047       enddo
3048       estr=0.5d0*AKP*estr+estr1
3049 c
3050 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3051 c
3052       do i=nnt,nct
3053         iti=itype(i)
3054         if (iti.ne.10 .and. iti.ne.21) then
3055           nbi=nbondterm(iti)
3056           if (nbi.eq.1) then
3057             diff=vbld(i+nres)-vbldsc0(1,iti)
3058 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3059 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3060             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3061             do j=1,3
3062               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3063             enddo
3064           else
3065             do j=1,nbi
3066               diff=vbld(i+nres)-vbldsc0(j,iti)
3067               ud(j)=aksc(j,iti)*diff
3068               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3069             enddo
3070             uprod=u(1)
3071             do j=2,nbi
3072               uprod=uprod*u(j)
3073             enddo
3074             usum=0.0d0
3075             usumsqder=0.0d0
3076             do j=1,nbi
3077               uprod1=1.0d0
3078               uprod2=1.0d0
3079               do k=1,nbi
3080                 if (k.ne.j) then
3081                   uprod1=uprod1*u(k)
3082                   uprod2=uprod2*u(k)*u(k)
3083                 endif
3084               enddo
3085               usum=usum+uprod1
3086               usumsqder=usumsqder+ud(j)*uprod2
3087             enddo
3088 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3089 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3090             estr=estr+uprod/usum
3091             do j=1,3
3092              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3093             enddo
3094           endif
3095         endif
3096       enddo
3097       return
3098       end
3099 #ifdef CRYST_THETA
3100 C--------------------------------------------------------------------------
3101       subroutine ebend(etheta)
3102 C
3103 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3104 C angles gamma and its derivatives in consecutive thetas and gammas.
3105 C
3106       implicit real*8 (a-h,o-z)
3107       include 'DIMENSIONS'
3108       include 'sizesclu.dat'
3109       include 'COMMON.LOCAL'
3110       include 'COMMON.GEO'
3111       include 'COMMON.INTERACT'
3112       include 'COMMON.DERIV'
3113       include 'COMMON.VAR'
3114       include 'COMMON.CHAIN'
3115       include 'COMMON.IOUNITS'
3116       include 'COMMON.NAMES'
3117       include 'COMMON.FFIELD'
3118       common /calcthet/ term1,term2,termm,diffak,ratak,
3119      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3120      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3121       double precision y(2),z(2)
3122       delta=0.02d0*pi
3123       time11=dexp(-2*time)
3124       time12=1.0d0
3125       etheta=0.0D0
3126 c      write (iout,*) "nres",nres
3127 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3128 c      write (iout,*) ithet_start,ithet_end
3129       do i=ithet_start,ithet_end
3130         if (itype(i-1).eq.21) cycle
3131 C Zero the energy function and its derivative at 0 or pi.
3132         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3133         it=itype(i-1)
3134         if (i.gt.3 .and. itype(i-2).ne.21) then
3135 #ifdef OSF
3136           phii=phi(i)
3137           icrc=0
3138           call proc_proc(phii,icrc)
3139           if (icrc.eq.1) phii=150.0
3140 #else
3141           phii=phi(i)
3142 #endif
3143           y(1)=dcos(phii)
3144           y(2)=dsin(phii)
3145         else
3146           y(1)=0.0D0
3147           y(2)=0.0D0
3148         endif
3149         if (i.lt.nres .and. itype(i).ne.21) then
3150 #ifdef OSF
3151           phii1=phi(i+1)
3152           icrc=0
3153           call proc_proc(phii1,icrc)
3154           if (icrc.eq.1) phii1=150.0
3155           phii1=pinorm(phii1)
3156           z(1)=cos(phii1)
3157 #else
3158           phii1=phi(i+1)
3159           z(1)=dcos(phii1)
3160 #endif
3161           z(2)=dsin(phii1)
3162         else
3163           z(1)=0.0D0
3164           z(2)=0.0D0
3165         endif
3166 C Calculate the "mean" value of theta from the part of the distribution
3167 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3168 C In following comments this theta will be referred to as t_c.
3169         thet_pred_mean=0.0d0
3170         do k=1,2
3171           athetk=athet(k,it)
3172           bthetk=bthet(k,it)
3173           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3174         enddo
3175 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3176         dthett=thet_pred_mean*ssd
3177         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3178 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3179 C Derivatives of the "mean" values in gamma1 and gamma2.
3180         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3181         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3182         if (theta(i).gt.pi-delta) then
3183           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3184      &         E_tc0)
3185           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3186           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3187           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3188      &        E_theta)
3189           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3190      &        E_tc)
3191         else if (theta(i).lt.delta) then
3192           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3193           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3194           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3195      &        E_theta)
3196           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3197           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3198      &        E_tc)
3199         else
3200           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3201      &        E_theta,E_tc)
3202         endif
3203         etheta=etheta+ethetai
3204 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3205 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3206         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3207         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3208         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3209  1215   continue
3210       enddo
3211 C Ufff.... We've done all this!!!
3212       return
3213       end
3214 C---------------------------------------------------------------------------
3215       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3216      &     E_tc)
3217       implicit real*8 (a-h,o-z)
3218       include 'DIMENSIONS'
3219       include 'COMMON.LOCAL'
3220       include 'COMMON.IOUNITS'
3221       common /calcthet/ term1,term2,termm,diffak,ratak,
3222      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3223      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3224 C Calculate the contributions to both Gaussian lobes.
3225 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3226 C The "polynomial part" of the "standard deviation" of this part of
3227 C the distribution.
3228         sig=polthet(3,it)
3229         do j=2,0,-1
3230           sig=sig*thet_pred_mean+polthet(j,it)
3231         enddo
3232 C Derivative of the "interior part" of the "standard deviation of the"
3233 C gamma-dependent Gaussian lobe in t_c.
3234         sigtc=3*polthet(3,it)
3235         do j=2,1,-1
3236           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3237         enddo
3238         sigtc=sig*sigtc
3239 C Set the parameters of both Gaussian lobes of the distribution.
3240 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3241         fac=sig*sig+sigc0(it)
3242         sigcsq=fac+fac
3243         sigc=1.0D0/sigcsq
3244 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3245         sigsqtc=-4.0D0*sigcsq*sigtc
3246 c       print *,i,sig,sigtc,sigsqtc
3247 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3248         sigtc=-sigtc/(fac*fac)
3249 C Following variable is sigma(t_c)**(-2)
3250         sigcsq=sigcsq*sigcsq
3251         sig0i=sig0(it)
3252         sig0inv=1.0D0/sig0i**2
3253         delthec=thetai-thet_pred_mean
3254         delthe0=thetai-theta0i
3255         term1=-0.5D0*sigcsq*delthec*delthec
3256         term2=-0.5D0*sig0inv*delthe0*delthe0
3257 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3258 C NaNs in taking the logarithm. We extract the largest exponent which is added
3259 C to the energy (this being the log of the distribution) at the end of energy
3260 C term evaluation for this virtual-bond angle.
3261         if (term1.gt.term2) then
3262           termm=term1
3263           term2=dexp(term2-termm)
3264           term1=1.0d0
3265         else
3266           termm=term2
3267           term1=dexp(term1-termm)
3268           term2=1.0d0
3269         endif
3270 C The ratio between the gamma-independent and gamma-dependent lobes of
3271 C the distribution is a Gaussian function of thet_pred_mean too.
3272         diffak=gthet(2,it)-thet_pred_mean
3273         ratak=diffak/gthet(3,it)**2
3274         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3275 C Let's differentiate it in thet_pred_mean NOW.
3276         aktc=ak*ratak
3277 C Now put together the distribution terms to make complete distribution.
3278         termexp=term1+ak*term2
3279         termpre=sigc+ak*sig0i
3280 C Contribution of the bending energy from this theta is just the -log of
3281 C the sum of the contributions from the two lobes and the pre-exponential
3282 C factor. Simple enough, isn't it?
3283         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3284 C NOW the derivatives!!!
3285 C 6/6/97 Take into account the deformation.
3286         E_theta=(delthec*sigcsq*term1
3287      &       +ak*delthe0*sig0inv*term2)/termexp
3288         E_tc=((sigtc+aktc*sig0i)/termpre
3289      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3290      &       aktc*term2)/termexp)
3291       return
3292       end
3293 c-----------------------------------------------------------------------------
3294       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3295       implicit real*8 (a-h,o-z)
3296       include 'DIMENSIONS'
3297       include 'COMMON.LOCAL'
3298       include 'COMMON.IOUNITS'
3299       common /calcthet/ term1,term2,termm,diffak,ratak,
3300      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3301      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3302       delthec=thetai-thet_pred_mean
3303       delthe0=thetai-theta0i
3304 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
3305       t3 = thetai-thet_pred_mean
3306       t6 = t3**2
3307       t9 = term1
3308       t12 = t3*sigcsq
3309       t14 = t12+t6*sigsqtc
3310       t16 = 1.0d0
3311       t21 = thetai-theta0i
3312       t23 = t21**2
3313       t26 = term2
3314       t27 = t21*t26
3315       t32 = termexp
3316       t40 = t32**2
3317       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
3318      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
3319      & *(-t12*t9-ak*sig0inv*t27)
3320       return
3321       end
3322 #else
3323 C--------------------------------------------------------------------------
3324       subroutine ebend(etheta)
3325 C
3326 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3327 C angles gamma and its derivatives in consecutive thetas and gammas.
3328 C ab initio-derived potentials from
3329 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
3330 C
3331       implicit real*8 (a-h,o-z)
3332       include 'DIMENSIONS'
3333       include 'sizesclu.dat'
3334       include 'COMMON.LOCAL'
3335       include 'COMMON.GEO'
3336       include 'COMMON.INTERACT'
3337       include 'COMMON.DERIV'
3338       include 'COMMON.VAR'
3339       include 'COMMON.CHAIN'
3340       include 'COMMON.IOUNITS'
3341       include 'COMMON.NAMES'
3342       include 'COMMON.FFIELD'
3343       include 'COMMON.CONTROL'
3344       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
3345      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
3346      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
3347      & sinph1ph2(maxdouble,maxdouble)
3348       logical lprn /.false./, lprn1 /.false./
3349       etheta=0.0D0
3350 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
3351       do i=ithet_start,ithet_end
3352         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
3353      &(itype(i).eq.ntyp1)) cycle
3354         dethetai=0.0d0
3355         dephii=0.0d0
3356         dephii1=0.0d0
3357         theti2=0.5d0*theta(i)
3358         ityp2=ithetyp(itype(i-1))
3359         do k=1,nntheterm
3360           coskt(k)=dcos(k*theti2)
3361           sinkt(k)=dsin(k*theti2)
3362         enddo
3363         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
3364 #ifdef OSF
3365           phii=phi(i)
3366           if (phii.ne.phii) phii=150.0
3367 #else
3368           phii=phi(i)
3369 #endif
3370           ityp1=ithetyp(itype(i-2))
3371           do k=1,nsingle
3372             cosph1(k)=dcos(k*phii)
3373             sinph1(k)=dsin(k*phii)
3374           enddo
3375         else
3376           phii=0.0d0
3377           ityp1=ithetyp(itype(i-2))
3378           do k=1,nsingle
3379             cosph1(k)=0.0d0
3380             sinph1(k)=0.0d0
3381           enddo
3382         endif
3383         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
3384 #ifdef OSF
3385           phii1=phi(i+1)
3386           if (phii1.ne.phii1) phii1=150.0
3387           phii1=pinorm(phii1)
3388 #else
3389           phii1=phi(i+1)
3390 #endif
3391           ityp3=ithetyp(itype(i))
3392           do k=1,nsingle
3393             cosph2(k)=dcos(k*phii1)
3394             sinph2(k)=dsin(k*phii1)
3395           enddo
3396         else
3397           phii1=0.0d0
3398           ityp3=ithetyp(itype(i))
3399           do k=1,nsingle
3400             cosph2(k)=0.0d0
3401             sinph2(k)=0.0d0
3402           enddo
3403         endif
3404 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
3405 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
3406 c        call flush(iout)
3407         ethetai=aa0thet(ityp1,ityp2,ityp3)
3408         do k=1,ndouble
3409           do l=1,k-1
3410             ccl=cosph1(l)*cosph2(k-l)
3411             ssl=sinph1(l)*sinph2(k-l)
3412             scl=sinph1(l)*cosph2(k-l)
3413             csl=cosph1(l)*sinph2(k-l)
3414             cosph1ph2(l,k)=ccl-ssl
3415             cosph1ph2(k,l)=ccl+ssl
3416             sinph1ph2(l,k)=scl+csl
3417             sinph1ph2(k,l)=scl-csl
3418           enddo
3419         enddo
3420         if (lprn) then
3421         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
3422      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
3423         write (iout,*) "coskt and sinkt"
3424         do k=1,nntheterm
3425           write (iout,*) k,coskt(k),sinkt(k)
3426         enddo
3427         endif
3428         do k=1,ntheterm
3429           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
3430           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
3431      &      *coskt(k)
3432           if (lprn)
3433      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
3434      &     " ethetai",ethetai
3435         enddo
3436         if (lprn) then
3437         write (iout,*) "cosph and sinph"
3438         do k=1,nsingle
3439           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
3440         enddo
3441         write (iout,*) "cosph1ph2 and sinph2ph2"
3442         do k=2,ndouble
3443           do l=1,k-1
3444             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
3445      &         sinph1ph2(l,k),sinph1ph2(k,l)
3446           enddo
3447         enddo
3448         write(iout,*) "ethetai",ethetai
3449         endif
3450         do m=1,ntheterm2
3451           do k=1,nsingle
3452             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
3453      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
3454      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
3455      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
3456             ethetai=ethetai+sinkt(m)*aux
3457             dethetai=dethetai+0.5d0*m*aux*coskt(m)
3458             dephii=dephii+k*sinkt(m)*(
3459      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
3460      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
3461             dephii1=dephii1+k*sinkt(m)*(
3462      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
3463      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
3464             if (lprn)
3465      &      write (iout,*) "m",m," k",k," bbthet",
3466      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
3467      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
3468      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
3469      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3470           enddo
3471         enddo
3472         if (lprn)
3473      &  write(iout,*) "ethetai",ethetai
3474         do m=1,ntheterm3
3475           do k=2,ndouble
3476             do l=1,k-1
3477               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3478      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
3479      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3480      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
3481               ethetai=ethetai+sinkt(m)*aux
3482               dethetai=dethetai+0.5d0*m*coskt(m)*aux
3483               dephii=dephii+l*sinkt(m)*(
3484      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
3485      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3486      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3487      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3488               dephii1=dephii1+(k-l)*sinkt(m)*(
3489      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3490      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3491      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
3492      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3493               if (lprn) then
3494               write (iout,*) "m",m," k",k," l",l," ffthet",
3495      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
3496      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
3497      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
3498      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3499               write (iout,*) cosph1ph2(l,k)*sinkt(m),
3500      &            cosph1ph2(k,l)*sinkt(m),
3501      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
3502               endif
3503             enddo
3504           enddo
3505         enddo
3506 10      continue
3507         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
3508      &   i,theta(i)*rad2deg,phii*rad2deg,
3509      &   phii1*rad2deg,ethetai
3510         etheta=etheta+ethetai
3511         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
3512         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
3513         gloc(nphi+i-2,icg)=wang*dethetai
3514       enddo
3515       return
3516       end
3517 #endif
3518 #ifdef CRYST_SC
3519 c-----------------------------------------------------------------------------
3520       subroutine esc(escloc)
3521 C Calculate the local energy of a side chain and its derivatives in the
3522 C corresponding virtual-bond valence angles THETA and the spherical angles
3523 C ALPHA and OMEGA.
3524       implicit real*8 (a-h,o-z)
3525       include 'DIMENSIONS'
3526       include 'sizesclu.dat'
3527       include 'COMMON.GEO'
3528       include 'COMMON.LOCAL'
3529       include 'COMMON.VAR'
3530       include 'COMMON.INTERACT'
3531       include 'COMMON.DERIV'
3532       include 'COMMON.CHAIN'
3533       include 'COMMON.IOUNITS'
3534       include 'COMMON.NAMES'
3535       include 'COMMON.FFIELD'
3536       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
3537      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
3538       common /sccalc/ time11,time12,time112,theti,it,nlobit
3539       delta=0.02d0*pi
3540       escloc=0.0D0
3541 c     write (iout,'(a)') 'ESC'
3542       do i=loc_start,loc_end
3543         it=itype(i)
3544         if (it.eq.21) cycle
3545         if (it.eq.10) goto 1
3546         nlobit=nlob(it)
3547 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
3548 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
3549         theti=theta(i+1)-pipol
3550         x(1)=dtan(theti)
3551         x(2)=alph(i)
3552         x(3)=omeg(i)
3553 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
3554
3555         if (x(2).gt.pi-delta) then
3556           xtemp(1)=x(1)
3557           xtemp(2)=pi-delta
3558           xtemp(3)=x(3)
3559           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3560           xtemp(2)=pi
3561           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3562           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
3563      &        escloci,dersc(2))
3564           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3565      &        ddersc0(1),dersc(1))
3566           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
3567      &        ddersc0(3),dersc(3))
3568           xtemp(2)=pi-delta
3569           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3570           xtemp(2)=pi
3571           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3572           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
3573      &            dersc0(2),esclocbi,dersc02)
3574           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3575      &            dersc12,dersc01)
3576           call splinthet(x(2),0.5d0*delta,ss,ssd)
3577           dersc0(1)=dersc01
3578           dersc0(2)=dersc02
3579           dersc0(3)=0.0d0
3580           do k=1,3
3581             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3582           enddo
3583           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3584 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3585 c    &             esclocbi,ss,ssd
3586           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3587 c         escloci=esclocbi
3588 c         write (iout,*) escloci
3589         else if (x(2).lt.delta) then
3590           xtemp(1)=x(1)
3591           xtemp(2)=delta
3592           xtemp(3)=x(3)
3593           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3594           xtemp(2)=0.0d0
3595           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3596           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
3597      &        escloci,dersc(2))
3598           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3599      &        ddersc0(1),dersc(1))
3600           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
3601      &        ddersc0(3),dersc(3))
3602           xtemp(2)=delta
3603           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3604           xtemp(2)=0.0d0
3605           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3606           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
3607      &            dersc0(2),esclocbi,dersc02)
3608           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3609      &            dersc12,dersc01)
3610           dersc0(1)=dersc01
3611           dersc0(2)=dersc02
3612           dersc0(3)=0.0d0
3613           call splinthet(x(2),0.5d0*delta,ss,ssd)
3614           do k=1,3
3615             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3616           enddo
3617           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3618 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3619 c    &             esclocbi,ss,ssd
3620           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3621 c         write (iout,*) escloci
3622         else
3623           call enesc(x,escloci,dersc,ddummy,.false.)
3624         endif
3625
3626         escloc=escloc+escloci
3627 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
3628
3629         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3630      &   wscloc*dersc(1)
3631         gloc(ialph(i,1),icg)=wscloc*dersc(2)
3632         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
3633     1   continue
3634       enddo
3635       return
3636       end
3637 C---------------------------------------------------------------------------
3638       subroutine enesc(x,escloci,dersc,ddersc,mixed)
3639       implicit real*8 (a-h,o-z)
3640       include 'DIMENSIONS'
3641       include 'COMMON.GEO'
3642       include 'COMMON.LOCAL'
3643       include 'COMMON.IOUNITS'
3644       common /sccalc/ time11,time12,time112,theti,it,nlobit
3645       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
3646       double precision contr(maxlob,-1:1)
3647       logical mixed
3648 c       write (iout,*) 'it=',it,' nlobit=',nlobit
3649         escloc_i=0.0D0
3650         do j=1,3
3651           dersc(j)=0.0D0
3652           if (mixed) ddersc(j)=0.0d0
3653         enddo
3654         x3=x(3)
3655
3656 C Because of periodicity of the dependence of the SC energy in omega we have
3657 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
3658 C To avoid underflows, first compute & store the exponents.
3659
3660         do iii=-1,1
3661
3662           x(3)=x3+iii*dwapi
3663
3664           do j=1,nlobit
3665             do k=1,3
3666               z(k)=x(k)-censc(k,j,it)
3667             enddo
3668             do k=1,3
3669               Axk=0.0D0
3670               do l=1,3
3671                 Axk=Axk+gaussc(l,k,j,it)*z(l)
3672               enddo
3673               Ax(k,j,iii)=Axk
3674             enddo
3675             expfac=0.0D0
3676             do k=1,3
3677               expfac=expfac+Ax(k,j,iii)*z(k)
3678             enddo
3679             contr(j,iii)=expfac
3680           enddo ! j
3681
3682         enddo ! iii
3683
3684         x(3)=x3
3685 C As in the case of ebend, we want to avoid underflows in exponentiation and
3686 C subsequent NaNs and INFs in energy calculation.
3687 C Find the largest exponent
3688         emin=contr(1,-1)
3689         do iii=-1,1
3690           do j=1,nlobit
3691             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
3692           enddo
3693         enddo
3694         emin=0.5D0*emin
3695 cd      print *,'it=',it,' emin=',emin
3696
3697 C Compute the contribution to SC energy and derivatives
3698         do iii=-1,1
3699
3700           do j=1,nlobit
3701             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
3702 cd          print *,'j=',j,' expfac=',expfac
3703             escloc_i=escloc_i+expfac
3704             do k=1,3
3705               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
3706             enddo
3707             if (mixed) then
3708               do k=1,3,2
3709                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
3710      &            +gaussc(k,2,j,it))*expfac
3711               enddo
3712             endif
3713           enddo
3714
3715         enddo ! iii
3716
3717         dersc(1)=dersc(1)/cos(theti)**2
3718         ddersc(1)=ddersc(1)/cos(theti)**2
3719         ddersc(3)=ddersc(3)
3720
3721         escloci=-(dlog(escloc_i)-emin)
3722         do j=1,3
3723           dersc(j)=dersc(j)/escloc_i
3724         enddo
3725         if (mixed) then
3726           do j=1,3,2
3727             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
3728           enddo
3729         endif
3730       return
3731       end
3732 C------------------------------------------------------------------------------
3733       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
3734       implicit real*8 (a-h,o-z)
3735       include 'DIMENSIONS'
3736       include 'COMMON.GEO'
3737       include 'COMMON.LOCAL'
3738       include 'COMMON.IOUNITS'
3739       common /sccalc/ time11,time12,time112,theti,it,nlobit
3740       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
3741       double precision contr(maxlob)
3742       logical mixed
3743
3744       escloc_i=0.0D0
3745
3746       do j=1,3
3747         dersc(j)=0.0D0
3748       enddo
3749
3750       do j=1,nlobit
3751         do k=1,2
3752           z(k)=x(k)-censc(k,j,it)
3753         enddo
3754         z(3)=dwapi
3755         do k=1,3
3756           Axk=0.0D0
3757           do l=1,3
3758             Axk=Axk+gaussc(l,k,j,it)*z(l)
3759           enddo
3760           Ax(k,j)=Axk
3761         enddo
3762         expfac=0.0D0
3763         do k=1,3
3764           expfac=expfac+Ax(k,j)*z(k)
3765         enddo
3766         contr(j)=expfac
3767       enddo ! j
3768
3769 C As in the case of ebend, we want to avoid underflows in exponentiation and
3770 C subsequent NaNs and INFs in energy calculation.
3771 C Find the largest exponent
3772       emin=contr(1)
3773       do j=1,nlobit
3774         if (emin.gt.contr(j)) emin=contr(j)
3775       enddo
3776       emin=0.5D0*emin
3777
3778 C Compute the contribution to SC energy and derivatives
3779
3780       dersc12=0.0d0
3781       do j=1,nlobit
3782         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
3783         escloc_i=escloc_i+expfac
3784         do k=1,2
3785           dersc(k)=dersc(k)+Ax(k,j)*expfac
3786         enddo
3787         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
3788      &            +gaussc(1,2,j,it))*expfac
3789         dersc(3)=0.0d0
3790       enddo
3791
3792       dersc(1)=dersc(1)/cos(theti)**2
3793       dersc12=dersc12/cos(theti)**2
3794       escloci=-(dlog(escloc_i)-emin)
3795       do j=1,2
3796         dersc(j)=dersc(j)/escloc_i
3797       enddo
3798       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
3799       return
3800       end
3801 #else
3802 c----------------------------------------------------------------------------------
3803       subroutine esc(escloc)
3804 C Calculate the local energy of a side chain and its derivatives in the
3805 C corresponding virtual-bond valence angles THETA and the spherical angles
3806 C ALPHA and OMEGA derived from AM1 all-atom calculations.
3807 C added by Urszula Kozlowska. 07/11/2007
3808 C
3809       implicit real*8 (a-h,o-z)
3810       include 'DIMENSIONS'
3811       include 'sizesclu.dat'
3812       include 'COMMON.GEO'
3813       include 'COMMON.LOCAL'
3814       include 'COMMON.VAR'
3815       include 'COMMON.SCROT'
3816       include 'COMMON.INTERACT'
3817       include 'COMMON.DERIV'
3818       include 'COMMON.CHAIN'
3819       include 'COMMON.IOUNITS'
3820       include 'COMMON.NAMES'
3821       include 'COMMON.FFIELD'
3822       include 'COMMON.CONTROL'
3823       include 'COMMON.VECTORS'
3824       double precision x_prime(3),y_prime(3),z_prime(3)
3825      &    , sumene,dsc_i,dp2_i,x(65),
3826      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
3827      &    de_dxx,de_dyy,de_dzz,de_dt
3828       double precision s1_t,s1_6_t,s2_t,s2_6_t
3829       double precision
3830      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
3831      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
3832      & dt_dCi(3),dt_dCi1(3)
3833       common /sccalc/ time11,time12,time112,theti,it,nlobit
3834       delta=0.02d0*pi
3835       escloc=0.0D0
3836       do i=loc_start,loc_end
3837         if (itype(i).eq.21) cycle
3838         costtab(i+1) =dcos(theta(i+1))
3839         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
3840         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
3841         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
3842         cosfac2=0.5d0/(1.0d0+costtab(i+1))
3843         cosfac=dsqrt(cosfac2)
3844         sinfac2=0.5d0/(1.0d0-costtab(i+1))
3845         sinfac=dsqrt(sinfac2)
3846         it=itype(i)
3847         if (it.eq.10) goto 1
3848 c
3849 C  Compute the axes of tghe local cartesian coordinates system; store in
3850 c   x_prime, y_prime and z_prime
3851 c
3852         do j=1,3
3853           x_prime(j) = 0.00
3854           y_prime(j) = 0.00
3855           z_prime(j) = 0.00
3856         enddo
3857 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
3858 C     &   dc_norm(3,i+nres)
3859         do j = 1,3
3860           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
3861           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
3862         enddo
3863         do j = 1,3
3864           z_prime(j) = -uz(j,i-1)
3865         enddo
3866 c       write (2,*) "i",i
3867 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
3868 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
3869 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
3870 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
3871 c      & " xy",scalar(x_prime(1),y_prime(1)),
3872 c      & " xz",scalar(x_prime(1),z_prime(1)),
3873 c      & " yy",scalar(y_prime(1),y_prime(1)),
3874 c      & " yz",scalar(y_prime(1),z_prime(1)),
3875 c      & " zz",scalar(z_prime(1),z_prime(1))
3876 c
3877 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
3878 C to local coordinate system. Store in xx, yy, zz.
3879 c
3880         xx=0.0d0
3881         yy=0.0d0
3882         zz=0.0d0
3883         do j = 1,3
3884           xx = xx + x_prime(j)*dc_norm(j,i+nres)
3885           yy = yy + y_prime(j)*dc_norm(j,i+nres)
3886           zz = zz + z_prime(j)*dc_norm(j,i+nres)
3887         enddo
3888
3889         xxtab(i)=xx
3890         yytab(i)=yy
3891         zztab(i)=zz
3892 C
3893 C Compute the energy of the ith side cbain
3894 C
3895 c        write (2,*) "xx",xx," yy",yy," zz",zz
3896         it=itype(i)
3897         do j = 1,65
3898           x(j) = sc_parmin(j,it)
3899         enddo
3900 #ifdef CHECK_COORD
3901 Cc diagnostics - remove later
3902         xx1 = dcos(alph(2))
3903         yy1 = dsin(alph(2))*dcos(omeg(2))
3904         zz1 = -dsin(alph(2))*dsin(omeg(2))
3905         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
3906      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
3907      &    xx1,yy1,zz1
3908 C,"  --- ", xx_w,yy_w,zz_w
3909 c end diagnostics
3910 #endif
3911         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
3912      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
3913      &   + x(10)*yy*zz
3914         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
3915      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
3916      & + x(20)*yy*zz
3917         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
3918      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
3919      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
3920      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
3921      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
3922      &  +x(40)*xx*yy*zz
3923         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
3924      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
3925      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
3926      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
3927      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
3928      &  +x(60)*xx*yy*zz
3929         dsc_i   = 0.743d0+x(61)
3930         dp2_i   = 1.9d0+x(62)
3931         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
3932      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
3933         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
3934      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
3935         s1=(1+x(63))/(0.1d0 + dscp1)
3936         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
3937         s2=(1+x(65))/(0.1d0 + dscp2)
3938         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
3939         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
3940      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
3941 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
3942 c     &   sumene4,
3943 c     &   dscp1,dscp2,sumene
3944 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
3945         escloc = escloc + sumene
3946 c        write (2,*) "escloc",escloc
3947         if (.not. calc_grad) goto 1
3948 #ifdef DEBUG
3949 C
3950 C This section to check the numerical derivatives of the energy of ith side
3951 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
3952 C #define DEBUG in the code to turn it on.
3953 C
3954         write (2,*) "sumene               =",sumene
3955         aincr=1.0d-7
3956         xxsave=xx
3957         xx=xx+aincr
3958         write (2,*) xx,yy,zz
3959         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
3960         de_dxx_num=(sumenep-sumene)/aincr
3961         xx=xxsave
3962         write (2,*) "xx+ sumene from enesc=",sumenep
3963         yysave=yy
3964         yy=yy+aincr
3965         write (2,*) xx,yy,zz
3966         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
3967         de_dyy_num=(sumenep-sumene)/aincr
3968         yy=yysave
3969         write (2,*) "yy+ sumene from enesc=",sumenep
3970         zzsave=zz
3971         zz=zz+aincr
3972         write (2,*) xx,yy,zz
3973         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
3974         de_dzz_num=(sumenep-sumene)/aincr
3975         zz=zzsave
3976         write (2,*) "zz+ sumene from enesc=",sumenep
3977         costsave=cost2tab(i+1)
3978         sintsave=sint2tab(i+1)
3979         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
3980         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
3981         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
3982         de_dt_num=(sumenep-sumene)/aincr
3983         write (2,*) " t+ sumene from enesc=",sumenep
3984         cost2tab(i+1)=costsave
3985         sint2tab(i+1)=sintsave
3986 C End of diagnostics section.
3987 #endif
3988 C
3989 C Compute the gradient of esc
3990 C
3991         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
3992         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
3993         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
3994         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
3995         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
3996         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
3997         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
3998         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
3999         pom1=(sumene3*sint2tab(i+1)+sumene1)
4000      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4001         pom2=(sumene4*cost2tab(i+1)+sumene2)
4002      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4003         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4004         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4005      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4006      &  +x(40)*yy*zz
4007         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4008         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4009      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4010      &  +x(60)*yy*zz
4011         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4012      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4013      &        +(pom1+pom2)*pom_dx
4014 #ifdef DEBUG
4015         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4016 #endif
4017 C
4018         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4019         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4020      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4021      &  +x(40)*xx*zz
4022         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4023         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4024      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4025      &  +x(59)*zz**2 +x(60)*xx*zz
4026         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4027      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4028      &        +(pom1-pom2)*pom_dy
4029 #ifdef DEBUG
4030         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4031 #endif
4032 C
4033         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4034      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4035      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4036      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4037      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4038      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4039      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4040      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4041 #ifdef DEBUG
4042         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4043 #endif
4044 C
4045         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4046      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4047      &  +pom1*pom_dt1+pom2*pom_dt2
4048 #ifdef DEBUG
4049         write(2,*), "de_dt = ", de_dt,de_dt_num
4050 #endif
4051 c
4052 C
4053        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4054        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4055        cosfac2xx=cosfac2*xx
4056        sinfac2yy=sinfac2*yy
4057        do k = 1,3
4058          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4059      &      vbld_inv(i+1)
4060          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4061      &      vbld_inv(i)
4062          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4063          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4064 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4065 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4066 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4067 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4068          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4069          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4070          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4071          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4072          dZZ_Ci1(k)=0.0d0
4073          dZZ_Ci(k)=0.0d0
4074          do j=1,3
4075            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4076            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4077          enddo
4078
4079          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4080          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4081          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4082 c
4083          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4084          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4085        enddo
4086
4087        do k=1,3
4088          dXX_Ctab(k,i)=dXX_Ci(k)
4089          dXX_C1tab(k,i)=dXX_Ci1(k)
4090          dYY_Ctab(k,i)=dYY_Ci(k)
4091          dYY_C1tab(k,i)=dYY_Ci1(k)
4092          dZZ_Ctab(k,i)=dZZ_Ci(k)
4093          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4094          dXX_XYZtab(k,i)=dXX_XYZ(k)
4095          dYY_XYZtab(k,i)=dYY_XYZ(k)
4096          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4097        enddo
4098
4099        do k = 1,3
4100 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4101 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4102 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4103 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4104 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4105 c     &    dt_dci(k)
4106 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4107 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4108          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4109      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4110          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4111      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4112          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4113      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4114        enddo
4115 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4116 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4117
4118 C to check gradient call subroutine check_grad
4119
4120     1 continue
4121       enddo
4122       return
4123       end
4124 #endif
4125 c------------------------------------------------------------------------------
4126       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4127 C
4128 C This procedure calculates two-body contact function g(rij) and its derivative:
4129 C
4130 C           eps0ij                                     !       x < -1
4131 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4132 C            0                                         !       x > 1
4133 C
4134 C where x=(rij-r0ij)/delta
4135 C
4136 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4137 C
4138       implicit none
4139       double precision rij,r0ij,eps0ij,fcont,fprimcont
4140       double precision x,x2,x4,delta
4141 c     delta=0.02D0*r0ij
4142 c      delta=0.2D0*r0ij
4143       x=(rij-r0ij)/delta
4144       if (x.lt.-1.0D0) then
4145         fcont=eps0ij
4146         fprimcont=0.0D0
4147       else if (x.le.1.0D0) then
4148         x2=x*x
4149         x4=x2*x2
4150         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4151         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4152       else
4153         fcont=0.0D0
4154         fprimcont=0.0D0
4155       endif
4156       return
4157       end
4158 c------------------------------------------------------------------------------
4159       subroutine splinthet(theti,delta,ss,ssder)
4160       implicit real*8 (a-h,o-z)
4161       include 'DIMENSIONS'
4162       include 'sizesclu.dat'
4163       include 'COMMON.VAR'
4164       include 'COMMON.GEO'
4165       thetup=pi-delta
4166       thetlow=delta
4167       if (theti.gt.pipol) then
4168         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4169       else
4170         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4171         ssder=-ssder
4172       endif
4173       return
4174       end
4175 c------------------------------------------------------------------------------
4176       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4177       implicit none
4178       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4179       double precision ksi,ksi2,ksi3,a1,a2,a3
4180       a1=fprim0*delta/(f1-f0)
4181       a2=3.0d0-2.0d0*a1
4182       a3=a1-2.0d0
4183       ksi=(x-x0)/delta
4184       ksi2=ksi*ksi
4185       ksi3=ksi2*ksi
4186       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4187       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4188       return
4189       end
4190 c------------------------------------------------------------------------------
4191       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4192       implicit none
4193       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4194       double precision ksi,ksi2,ksi3,a1,a2,a3
4195       ksi=(x-x0)/delta
4196       ksi2=ksi*ksi
4197       ksi3=ksi2*ksi
4198       a1=fprim0x*delta
4199       a2=3*(f1x-f0x)-2*fprim0x*delta
4200       a3=fprim0x*delta-2*(f1x-f0x)
4201       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4202       return
4203       end
4204 C-----------------------------------------------------------------------------
4205 #ifdef CRYST_TOR
4206 C-----------------------------------------------------------------------------
4207       subroutine etor(etors,edihcnstr,fact)
4208       implicit real*8 (a-h,o-z)
4209       include 'DIMENSIONS'
4210       include 'sizesclu.dat'
4211       include 'COMMON.VAR'
4212       include 'COMMON.GEO'
4213       include 'COMMON.LOCAL'
4214       include 'COMMON.TORSION'
4215       include 'COMMON.INTERACT'
4216       include 'COMMON.DERIV'
4217       include 'COMMON.CHAIN'
4218       include 'COMMON.NAMES'
4219       include 'COMMON.IOUNITS'
4220       include 'COMMON.FFIELD'
4221       include 'COMMON.TORCNSTR'
4222       logical lprn
4223 C Set lprn=.true. for debugging
4224       lprn=.false.
4225 c      lprn=.true.
4226       etors=0.0D0
4227       do i=iphi_start,iphi_end
4228         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
4229      &      .or. itype(i).eq.21) cycle
4230         itori=itortyp(itype(i-2))
4231         itori1=itortyp(itype(i-1))
4232         phii=phi(i)
4233         gloci=0.0D0
4234 C Proline-Proline pair is a special case...
4235         if (itori.eq.3 .and. itori1.eq.3) then
4236           if (phii.gt.-dwapi3) then
4237             cosphi=dcos(3*phii)
4238             fac=1.0D0/(1.0D0-cosphi)
4239             etorsi=v1(1,3,3)*fac
4240             etorsi=etorsi+etorsi
4241             etors=etors+etorsi-v1(1,3,3)
4242             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4243           endif
4244           do j=1,3
4245             v1ij=v1(j+1,itori,itori1)
4246             v2ij=v2(j+1,itori,itori1)
4247             cosphi=dcos(j*phii)
4248             sinphi=dsin(j*phii)
4249             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4250             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4251           enddo
4252         else
4253           do j=1,nterm_old
4254             v1ij=v1(j,itori,itori1)
4255             v2ij=v2(j,itori,itori1)
4256             cosphi=dcos(j*phii)
4257             sinphi=dsin(j*phii)
4258             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4259             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4260           enddo
4261         endif
4262         if (lprn)
4263      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4264      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4265      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4266         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4267 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4268       enddo
4269 ! 6/20/98 - dihedral angle constraints
4270       edihcnstr=0.0d0
4271       do i=1,ndih_constr
4272         itori=idih_constr(i)
4273         phii=phi(itori)
4274         difi=phii-phi0(i)
4275         if (difi.gt.drange(i)) then
4276           difi=difi-drange(i)
4277           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4278           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4279         else if (difi.lt.-drange(i)) then
4280           difi=difi+drange(i)
4281           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4282           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4283         endif
4284 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4285 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4286       enddo
4287 !      write (iout,*) 'edihcnstr',edihcnstr
4288       return
4289       end
4290 c------------------------------------------------------------------------------
4291 #else
4292       subroutine etor(etors,edihcnstr,fact)
4293       implicit real*8 (a-h,o-z)
4294       include 'DIMENSIONS'
4295       include 'sizesclu.dat'
4296       include 'COMMON.VAR'
4297       include 'COMMON.GEO'
4298       include 'COMMON.LOCAL'
4299       include 'COMMON.TORSION'
4300       include 'COMMON.INTERACT'
4301       include 'COMMON.DERIV'
4302       include 'COMMON.CHAIN'
4303       include 'COMMON.NAMES'
4304       include 'COMMON.IOUNITS'
4305       include 'COMMON.FFIELD'
4306       include 'COMMON.TORCNSTR'
4307       logical lprn
4308 C Set lprn=.true. for debugging
4309       lprn=.false.
4310 c      lprn=.true.
4311       etors=0.0D0
4312       do i=iphi_start,iphi_end
4313         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
4314      &       .or. itype(i).eq.21) cycle
4315         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4316         itori=itortyp(itype(i-2))
4317         itori1=itortyp(itype(i-1))
4318         phii=phi(i)
4319         gloci=0.0D0
4320 C Regular cosine and sine terms
4321         do j=1,nterm(itori,itori1)
4322           v1ij=v1(j,itori,itori1)
4323           v2ij=v2(j,itori,itori1)
4324           cosphi=dcos(j*phii)
4325           sinphi=dsin(j*phii)
4326           etors=etors+v1ij*cosphi+v2ij*sinphi
4327           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4328         enddo
4329 C Lorentz terms
4330 C                         v1
4331 C  E = SUM ----------------------------------- - v1
4332 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4333 C
4334         cosphi=dcos(0.5d0*phii)
4335         sinphi=dsin(0.5d0*phii)
4336         do j=1,nlor(itori,itori1)
4337           vl1ij=vlor1(j,itori,itori1)
4338           vl2ij=vlor2(j,itori,itori1)
4339           vl3ij=vlor3(j,itori,itori1)
4340           pom=vl2ij*cosphi+vl3ij*sinphi
4341           pom1=1.0d0/(pom*pom+1.0d0)
4342           etors=etors+vl1ij*pom1
4343           pom=-pom*pom1*pom1
4344           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4345         enddo
4346 C Subtract the constant term
4347         etors=etors-v0(itori,itori1)
4348         if (lprn)
4349      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4350      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4351      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4352         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4353 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4354  1215   continue
4355       enddo
4356 ! 6/20/98 - dihedral angle constraints
4357       edihcnstr=0.0d0
4358       do i=1,ndih_constr
4359         itori=idih_constr(i)
4360         phii=phi(itori)
4361         difi=pinorm(phii-phi0(i))
4362         edihi=0.0d0
4363         if (difi.gt.drange(i)) then
4364           difi=difi-drange(i)
4365           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4366           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4367           edihi=0.25d0*ftors*difi**4
4368         else if (difi.lt.-drange(i)) then
4369           difi=difi+drange(i)
4370           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4371           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4372           edihi=0.25d0*ftors*difi**4
4373         else
4374           difi=0.0d0
4375         endif
4376 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
4377 c     &    drange(i),edihi
4378 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4379 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4380       enddo
4381 !      write (iout,*) 'edihcnstr',edihcnstr
4382       return
4383       end
4384 c----------------------------------------------------------------------------
4385       subroutine etor_d(etors_d,fact2)
4386 C 6/23/01 Compute double torsional energy
4387       implicit real*8 (a-h,o-z)
4388       include 'DIMENSIONS'
4389       include 'sizesclu.dat'
4390       include 'COMMON.VAR'
4391       include 'COMMON.GEO'
4392       include 'COMMON.LOCAL'
4393       include 'COMMON.TORSION'
4394       include 'COMMON.INTERACT'
4395       include 'COMMON.DERIV'
4396       include 'COMMON.CHAIN'
4397       include 'COMMON.NAMES'
4398       include 'COMMON.IOUNITS'
4399       include 'COMMON.FFIELD'
4400       include 'COMMON.TORCNSTR'
4401       logical lprn
4402 C Set lprn=.true. for debugging
4403       lprn=.false.
4404 c     lprn=.true.
4405       etors_d=0.0D0
4406       do i=iphi_start,iphi_end-1
4407         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
4408      &      .or. itype(i).eq.21 .or. itype(i+1).eq.21) cycle
4409         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
4410      &     goto 1215
4411         itori=itortyp(itype(i-2))
4412         itori1=itortyp(itype(i-1))
4413         itori2=itortyp(itype(i))
4414         phii=phi(i)
4415         phii1=phi(i+1)
4416         gloci1=0.0D0
4417         gloci2=0.0D0
4418 C Regular cosine and sine terms
4419         do j=1,ntermd_1(itori,itori1,itori2)
4420           v1cij=v1c(1,j,itori,itori1,itori2)
4421           v1sij=v1s(1,j,itori,itori1,itori2)
4422           v2cij=v1c(2,j,itori,itori1,itori2)
4423           v2sij=v1s(2,j,itori,itori1,itori2)
4424           cosphi1=dcos(j*phii)
4425           sinphi1=dsin(j*phii)
4426           cosphi2=dcos(j*phii1)
4427           sinphi2=dsin(j*phii1)
4428           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
4429      &     v2cij*cosphi2+v2sij*sinphi2
4430           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
4431           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
4432         enddo
4433         do k=2,ntermd_2(itori,itori1,itori2)
4434           do l=1,k-1
4435             v1cdij = v2c(k,l,itori,itori1,itori2)
4436             v2cdij = v2c(l,k,itori,itori1,itori2)
4437             v1sdij = v2s(k,l,itori,itori1,itori2)
4438             v2sdij = v2s(l,k,itori,itori1,itori2)
4439             cosphi1p2=dcos(l*phii+(k-l)*phii1)
4440             cosphi1m2=dcos(l*phii-(k-l)*phii1)
4441             sinphi1p2=dsin(l*phii+(k-l)*phii1)
4442             sinphi1m2=dsin(l*phii-(k-l)*phii1)
4443             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
4444      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
4445             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
4446      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
4447             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
4448      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
4449           enddo
4450         enddo
4451         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
4452         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
4453  1215   continue
4454       enddo
4455       return
4456       end
4457 #endif
4458 c------------------------------------------------------------------------------
4459       subroutine eback_sc_corr(esccor)
4460 c 7/21/2007 Correlations between the backbone-local and side-chain-local
4461 c        conformational states; temporarily implemented as differences
4462 c        between UNRES torsional potentials (dependent on three types of
4463 c        residues) and the torsional potentials dependent on all 20 types
4464 c        of residues computed from AM1 energy surfaces of terminally-blocked
4465 c        amino-acid residues.
4466       implicit real*8 (a-h,o-z)
4467       include 'DIMENSIONS'
4468       include 'sizesclu.dat'
4469       include 'COMMON.VAR'
4470       include 'COMMON.GEO'
4471       include 'COMMON.LOCAL'
4472       include 'COMMON.TORSION'
4473       include 'COMMON.SCCOR'
4474       include 'COMMON.INTERACT'
4475       include 'COMMON.DERIV'
4476       include 'COMMON.CHAIN'
4477       include 'COMMON.NAMES'
4478       include 'COMMON.IOUNITS'
4479       include 'COMMON.FFIELD'
4480       include 'COMMON.CONTROL'
4481       logical lprn
4482 C Set lprn=.true. for debugging
4483       lprn=.false.
4484 c      lprn=.true.
4485 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
4486       esccor=0.0D0
4487       do i=itau_start,itau_end
4488         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1) cycle
4489         esccor_ii=0.0D0
4490         isccori=isccortyp(itype(i-2))
4491         isccori1=isccortyp(itype(i-1))
4492         phii=phi(i)
4493         do intertyp=1,3 !intertyp
4494 cc Added 09 May 2012 (Adasko)
4495 cc  Intertyp means interaction type of backbone mainchain correlation:
4496 c   1 = SC...Ca...Ca...Ca
4497 c   2 = Ca...Ca...Ca...SC
4498 c   3 = SC...Ca...Ca...SCi
4499         gloci=0.0D0
4500         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
4501      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
4502      &      (itype(i-1).eq.ntyp1)))
4503      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
4504      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
4505      &     .or.(itype(i).eq.ntyp1)))
4506      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
4507      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4508      &      (itype(i-3).eq.ntyp1)))) cycle
4509         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
4510         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
4511      & cycle
4512        do j=1,nterm_sccor(isccori,isccori1)
4513           v1ij=v1sccor(j,intertyp,isccori,isccori1)
4514           v2ij=v2sccor(j,intertyp,isccori,isccori1)
4515           cosphi=dcos(j*tauangle(intertyp,i))
4516           sinphi=dsin(j*tauangle(intertyp,i))
4517            esccor=esccor+v1ij*cosphi+v2ij*sinphi
4518 c           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4519          enddo
4520 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
4521 c      gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+wsccor*gloci
4522         if (lprn)
4523      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4524      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4525      &  (v1sccor(j,1,itori,itori1),j=1,6),
4526      &  (v2sccor(j,1,itori,itori1),j=1,6)
4527         gsccor_loc(i-3)=gloci
4528        enddo !intertyp
4529       enddo
4530       return
4531       end
4532 c------------------------------------------------------------------------------
4533       subroutine multibody(ecorr)
4534 C This subroutine calculates multi-body contributions to energy following
4535 C the idea of Skolnick et al. If side chains I and J make a contact and
4536 C at the same time side chains I+1 and J+1 make a contact, an extra
4537 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
4538       implicit real*8 (a-h,o-z)
4539       include 'DIMENSIONS'
4540       include 'COMMON.IOUNITS'
4541       include 'COMMON.DERIV'
4542       include 'COMMON.INTERACT'
4543       include 'COMMON.CONTACTS'
4544       double precision gx(3),gx1(3)
4545       logical lprn
4546
4547 C Set lprn=.true. for debugging
4548       lprn=.false.
4549
4550       if (lprn) then
4551         write (iout,'(a)') 'Contact function values:'
4552         do i=nnt,nct-2
4553           write (iout,'(i2,20(1x,i2,f10.5))')
4554      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
4555         enddo
4556       endif
4557       ecorr=0.0D0
4558       do i=nnt,nct
4559         do j=1,3
4560           gradcorr(j,i)=0.0D0
4561           gradxorr(j,i)=0.0D0
4562         enddo
4563       enddo
4564       do i=nnt,nct-2
4565
4566         DO ISHIFT = 3,4
4567
4568         i1=i+ishift
4569         num_conti=num_cont(i)
4570         num_conti1=num_cont(i1)
4571         do jj=1,num_conti
4572           j=jcont(jj,i)
4573           do kk=1,num_conti1
4574             j1=jcont(kk,i1)
4575             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
4576 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4577 cd   &                   ' ishift=',ishift
4578 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
4579 C The system gains extra energy.
4580               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
4581             endif   ! j1==j+-ishift
4582           enddo     ! kk
4583         enddo       ! jj
4584
4585         ENDDO ! ISHIFT
4586
4587       enddo         ! i
4588       return
4589       end
4590 c------------------------------------------------------------------------------
4591       double precision function esccorr(i,j,k,l,jj,kk)
4592       implicit real*8 (a-h,o-z)
4593       include 'DIMENSIONS'
4594       include 'COMMON.IOUNITS'
4595       include 'COMMON.DERIV'
4596       include 'COMMON.INTERACT'
4597       include 'COMMON.CONTACTS'
4598       double precision gx(3),gx1(3)
4599       logical lprn
4600       lprn=.false.
4601       eij=facont(jj,i)
4602       ekl=facont(kk,k)
4603 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
4604 C Calculate the multi-body contribution to energy.
4605 C Calculate multi-body contributions to the gradient.
4606 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
4607 cd   & k,l,(gacont(m,kk,k),m=1,3)
4608       do m=1,3
4609         gx(m) =ekl*gacont(m,jj,i)
4610         gx1(m)=eij*gacont(m,kk,k)
4611         gradxorr(m,i)=gradxorr(m,i)-gx(m)
4612         gradxorr(m,j)=gradxorr(m,j)+gx(m)
4613         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
4614         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
4615       enddo
4616       do m=i,j-1
4617         do ll=1,3
4618           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
4619         enddo
4620       enddo
4621       do m=k,l-1
4622         do ll=1,3
4623           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
4624         enddo
4625       enddo
4626       esccorr=-eij*ekl
4627       return
4628       end
4629 c------------------------------------------------------------------------------
4630 #ifdef MPL
4631       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
4632       implicit real*8 (a-h,o-z)
4633       include 'DIMENSIONS'
4634       integer dimen1,dimen2,atom,indx
4635       double precision buffer(dimen1,dimen2)
4636       double precision zapas
4637       common /contacts_hb/ zapas(3,20,maxres,7),
4638      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4639      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4640       num_kont=num_cont_hb(atom)
4641       do i=1,num_kont
4642         do k=1,7
4643           do j=1,3
4644             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
4645           enddo ! j
4646         enddo ! k
4647         buffer(i,indx+22)=facont_hb(i,atom)
4648         buffer(i,indx+23)=ees0p(i,atom)
4649         buffer(i,indx+24)=ees0m(i,atom)
4650         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
4651       enddo ! i
4652       buffer(1,indx+26)=dfloat(num_kont)
4653       return
4654       end
4655 c------------------------------------------------------------------------------
4656       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
4657       implicit real*8 (a-h,o-z)
4658       include 'DIMENSIONS'
4659       integer dimen1,dimen2,atom,indx
4660       double precision buffer(dimen1,dimen2)
4661       double precision zapas
4662       common /contacts_hb/ zapas(3,20,maxres,7),
4663      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4664      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4665       num_kont=buffer(1,indx+26)
4666       num_kont_old=num_cont_hb(atom)
4667       num_cont_hb(atom)=num_kont+num_kont_old
4668       do i=1,num_kont
4669         ii=i+num_kont_old
4670         do k=1,7
4671           do j=1,3
4672             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
4673           enddo ! j
4674         enddo ! k
4675         facont_hb(ii,atom)=buffer(i,indx+22)
4676         ees0p(ii,atom)=buffer(i,indx+23)
4677         ees0m(ii,atom)=buffer(i,indx+24)
4678         jcont_hb(ii,atom)=buffer(i,indx+25)
4679       enddo ! i
4680       return
4681       end
4682 c------------------------------------------------------------------------------
4683 #endif
4684       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
4685 C This subroutine calculates multi-body contributions to hydrogen-bonding
4686       implicit real*8 (a-h,o-z)
4687       include 'DIMENSIONS'
4688       include 'sizesclu.dat'
4689       include 'COMMON.IOUNITS'
4690 #ifdef MPL
4691       include 'COMMON.INFO'
4692 #endif
4693       include 'COMMON.FFIELD'
4694       include 'COMMON.DERIV'
4695       include 'COMMON.INTERACT'
4696       include 'COMMON.CONTACTS'
4697 #ifdef MPL
4698       parameter (max_cont=maxconts)
4699       parameter (max_dim=2*(8*3+2))
4700       parameter (msglen1=max_cont*max_dim*4)
4701       parameter (msglen2=2*msglen1)
4702       integer source,CorrelType,CorrelID,Error
4703       double precision buffer(max_cont,max_dim)
4704 #endif
4705       double precision gx(3),gx1(3)
4706       logical lprn,ldone
4707
4708 C Set lprn=.true. for debugging
4709       lprn=.false.
4710 #ifdef MPL
4711       n_corr=0
4712       n_corr1=0
4713       if (fgProcs.le.1) goto 30
4714       if (lprn) then
4715         write (iout,'(a)') 'Contact function values:'
4716         do i=nnt,nct-2
4717           write (iout,'(2i3,50(1x,i2,f5.2))')
4718      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4719      &    j=1,num_cont_hb(i))
4720         enddo
4721       endif
4722 C Caution! Following code assumes that electrostatic interactions concerning
4723 C a given atom are split among at most two processors!
4724       CorrelType=477
4725       CorrelID=MyID+1
4726       ldone=.false.
4727       do i=1,max_cont
4728         do j=1,max_dim
4729           buffer(i,j)=0.0D0
4730         enddo
4731       enddo
4732       mm=mod(MyRank,2)
4733 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
4734       if (mm) 20,20,10
4735    10 continue
4736 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
4737       if (MyRank.gt.0) then
4738 C Send correlation contributions to the preceding processor
4739         msglen=msglen1
4740         nn=num_cont_hb(iatel_s)
4741         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
4742 cd      write (iout,*) 'The BUFFER array:'
4743 cd      do i=1,nn
4744 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
4745 cd      enddo
4746         if (ielstart(iatel_s).gt.iatel_s+ispp) then
4747           msglen=msglen2
4748             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
4749 C Clear the contacts of the atom passed to the neighboring processor
4750         nn=num_cont_hb(iatel_s+1)
4751 cd      do i=1,nn
4752 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
4753 cd      enddo
4754             num_cont_hb(iatel_s)=0
4755         endif
4756 cd      write (iout,*) 'Processor ',MyID,MyRank,
4757 cd   & ' is sending correlation contribution to processor',MyID-1,
4758 cd   & ' msglen=',msglen
4759 cd      write (*,*) 'Processor ',MyID,MyRank,
4760 cd   & ' is sending correlation contribution to processor',MyID-1,
4761 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4762         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
4763 cd      write (iout,*) 'Processor ',MyID,
4764 cd   & ' has sent correlation contribution to processor',MyID-1,
4765 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4766 cd      write (*,*) 'Processor ',MyID,
4767 cd   & ' has sent correlation contribution to processor',MyID-1,
4768 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4769         msglen=msglen1
4770       endif ! (MyRank.gt.0)
4771       if (ldone) goto 30
4772       ldone=.true.
4773    20 continue
4774 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
4775       if (MyRank.lt.fgProcs-1) then
4776 C Receive correlation contributions from the next processor
4777         msglen=msglen1
4778         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
4779 cd      write (iout,*) 'Processor',MyID,
4780 cd   & ' is receiving correlation contribution from processor',MyID+1,
4781 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4782 cd      write (*,*) 'Processor',MyID,
4783 cd   & ' is receiving correlation contribution from processor',MyID+1,
4784 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4785         nbytes=-1
4786         do while (nbytes.le.0)
4787           call mp_probe(MyID+1,CorrelType,nbytes)
4788         enddo
4789 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
4790         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
4791 cd      write (iout,*) 'Processor',MyID,
4792 cd   & ' has received correlation contribution from processor',MyID+1,
4793 cd   & ' msglen=',msglen,' nbytes=',nbytes
4794 cd      write (iout,*) 'The received BUFFER array:'
4795 cd      do i=1,max_cont
4796 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
4797 cd      enddo
4798         if (msglen.eq.msglen1) then
4799           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
4800         else if (msglen.eq.msglen2)  then
4801           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
4802           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
4803         else
4804           write (iout,*)
4805      & 'ERROR!!!! message length changed while processing correlations.'
4806           write (*,*)
4807      & 'ERROR!!!! message length changed while processing correlations.'
4808           call mp_stopall(Error)
4809         endif ! msglen.eq.msglen1
4810       endif ! MyRank.lt.fgProcs-1
4811       if (ldone) goto 30
4812       ldone=.true.
4813       goto 10
4814    30 continue
4815 #endif
4816       if (lprn) then
4817         write (iout,'(a)') 'Contact function values:'
4818         do i=nnt,nct-2
4819           write (iout,'(2i3,50(1x,i2,f5.2))')
4820      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4821      &    j=1,num_cont_hb(i))
4822         enddo
4823       endif
4824       ecorr=0.0D0
4825 C Remove the loop below after debugging !!!
4826       do i=nnt,nct
4827         do j=1,3
4828           gradcorr(j,i)=0.0D0
4829           gradxorr(j,i)=0.0D0
4830         enddo
4831       enddo
4832 C Calculate the local-electrostatic correlation terms
4833       do i=iatel_s,iatel_e+1
4834         i1=i+1
4835         num_conti=num_cont_hb(i)
4836         num_conti1=num_cont_hb(i+1)
4837         do jj=1,num_conti
4838           j=jcont_hb(jj,i)
4839           do kk=1,num_conti1
4840             j1=jcont_hb(kk,i1)
4841 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4842 c     &         ' jj=',jj,' kk=',kk
4843             if (j1.eq.j+1 .or. j1.eq.j-1) then
4844 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
4845 C The system gains extra energy.
4846               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
4847               n_corr=n_corr+1
4848             else if (j1.eq.j) then
4849 C Contacts I-J and I-(J+1) occur simultaneously.
4850 C The system loses extra energy.
4851 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
4852             endif
4853           enddo ! kk
4854           do kk=1,num_conti
4855             j1=jcont_hb(kk,i)
4856 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4857 c    &         ' jj=',jj,' kk=',kk
4858             if (j1.eq.j+1) then
4859 C Contacts I-J and (I+1)-J occur simultaneously.
4860 C The system loses extra energy.
4861 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
4862             endif ! j1==j+1
4863           enddo ! kk
4864         enddo ! jj
4865       enddo ! i
4866       return
4867       end
4868 c------------------------------------------------------------------------------
4869       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
4870      &  n_corr1)
4871 C This subroutine calculates multi-body contributions to hydrogen-bonding
4872       implicit real*8 (a-h,o-z)
4873       include 'DIMENSIONS'
4874       include 'sizesclu.dat'
4875       include 'COMMON.IOUNITS'
4876 #ifdef MPL
4877       include 'COMMON.INFO'
4878 #endif
4879       include 'COMMON.FFIELD'
4880       include 'COMMON.DERIV'
4881       include 'COMMON.INTERACT'
4882       include 'COMMON.CONTACTS'
4883 #ifdef MPL
4884       parameter (max_cont=maxconts)
4885       parameter (max_dim=2*(8*3+2))
4886       parameter (msglen1=max_cont*max_dim*4)
4887       parameter (msglen2=2*msglen1)
4888       integer source,CorrelType,CorrelID,Error
4889       double precision buffer(max_cont,max_dim)
4890 #endif
4891       double precision gx(3),gx1(3)
4892       logical lprn,ldone
4893
4894 C Set lprn=.true. for debugging
4895       lprn=.false.
4896       eturn6=0.0d0
4897 #ifdef MPL
4898       n_corr=0
4899       n_corr1=0
4900       if (fgProcs.le.1) goto 30
4901       if (lprn) then
4902         write (iout,'(a)') 'Contact function values:'
4903         do i=nnt,nct-2
4904           write (iout,'(2i3,50(1x,i2,f5.2))')
4905      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4906      &    j=1,num_cont_hb(i))
4907         enddo
4908       endif
4909 C Caution! Following code assumes that electrostatic interactions concerning
4910 C a given atom are split among at most two processors!
4911       CorrelType=477
4912       CorrelID=MyID+1
4913       ldone=.false.
4914       do i=1,max_cont
4915         do j=1,max_dim
4916           buffer(i,j)=0.0D0
4917         enddo
4918       enddo
4919       mm=mod(MyRank,2)
4920 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
4921       if (mm) 20,20,10
4922    10 continue
4923 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
4924       if (MyRank.gt.0) then
4925 C Send correlation contributions to the preceding processor
4926         msglen=msglen1
4927         nn=num_cont_hb(iatel_s)
4928         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
4929 cd      write (iout,*) 'The BUFFER array:'
4930 cd      do i=1,nn
4931 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
4932 cd      enddo
4933         if (ielstart(iatel_s).gt.iatel_s+ispp) then
4934           msglen=msglen2
4935             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
4936 C Clear the contacts of the atom passed to the neighboring processor
4937         nn=num_cont_hb(iatel_s+1)
4938 cd      do i=1,nn
4939 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
4940 cd      enddo
4941             num_cont_hb(iatel_s)=0
4942         endif
4943 cd      write (iout,*) 'Processor ',MyID,MyRank,
4944 cd   & ' is sending correlation contribution to processor',MyID-1,
4945 cd   & ' msglen=',msglen
4946 cd      write (*,*) 'Processor ',MyID,MyRank,
4947 cd   & ' is sending correlation contribution to processor',MyID-1,
4948 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4949         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
4950 cd      write (iout,*) 'Processor ',MyID,
4951 cd   & ' has sent correlation contribution to processor',MyID-1,
4952 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4953 cd      write (*,*) 'Processor ',MyID,
4954 cd   & ' has sent correlation contribution to processor',MyID-1,
4955 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4956         msglen=msglen1
4957       endif ! (MyRank.gt.0)
4958       if (ldone) goto 30
4959       ldone=.true.
4960    20 continue
4961 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
4962       if (MyRank.lt.fgProcs-1) then
4963 C Receive correlation contributions from the next processor
4964         msglen=msglen1
4965         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
4966 cd      write (iout,*) 'Processor',MyID,
4967 cd   & ' is receiving correlation contribution from processor',MyID+1,
4968 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4969 cd      write (*,*) 'Processor',MyID,
4970 cd   & ' is receiving correlation contribution from processor',MyID+1,
4971 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4972         nbytes=-1
4973         do while (nbytes.le.0)
4974           call mp_probe(MyID+1,CorrelType,nbytes)
4975         enddo
4976 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
4977         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
4978 cd      write (iout,*) 'Processor',MyID,
4979 cd   & ' has received correlation contribution from processor',MyID+1,
4980 cd   & ' msglen=',msglen,' nbytes=',nbytes
4981 cd      write (iout,*) 'The received BUFFER array:'
4982 cd      do i=1,max_cont
4983 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
4984 cd      enddo
4985         if (msglen.eq.msglen1) then
4986           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
4987         else if (msglen.eq.msglen2)  then
4988           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
4989           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
4990         else
4991           write (iout,*)
4992      & 'ERROR!!!! message length changed while processing correlations.'
4993           write (*,*)
4994      & 'ERROR!!!! message length changed while processing correlations.'
4995           call mp_stopall(Error)
4996         endif ! msglen.eq.msglen1
4997       endif ! MyRank.lt.fgProcs-1
4998       if (ldone) goto 30
4999       ldone=.true.
5000       goto 10
5001    30 continue
5002 #endif
5003       if (lprn) then
5004         write (iout,'(a)') 'Contact function values:'
5005         do i=nnt,nct-2
5006           write (iout,'(2i3,50(1x,i2,f5.2))')
5007      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5008      &    j=1,num_cont_hb(i))
5009         enddo
5010       endif
5011       ecorr=0.0D0
5012       ecorr5=0.0d0
5013       ecorr6=0.0d0
5014 C Remove the loop below after debugging !!!
5015       do i=nnt,nct
5016         do j=1,3
5017           gradcorr(j,i)=0.0D0
5018           gradxorr(j,i)=0.0D0
5019         enddo
5020       enddo
5021 C Calculate the dipole-dipole interaction energies
5022       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5023       do i=iatel_s,iatel_e+1
5024         num_conti=num_cont_hb(i)
5025         do jj=1,num_conti
5026           j=jcont_hb(jj,i)
5027           call dipole(i,j,jj)
5028         enddo
5029       enddo
5030       endif
5031 C Calculate the local-electrostatic correlation terms
5032       do i=iatel_s,iatel_e+1
5033         i1=i+1
5034         num_conti=num_cont_hb(i)
5035         num_conti1=num_cont_hb(i+1)
5036         do jj=1,num_conti
5037           j=jcont_hb(jj,i)
5038           do kk=1,num_conti1
5039             j1=jcont_hb(kk,i1)
5040 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5041 c     &         ' jj=',jj,' kk=',kk
5042             if (j1.eq.j+1 .or. j1.eq.j-1) then
5043 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5044 C The system gains extra energy.
5045               n_corr=n_corr+1
5046               sqd1=dsqrt(d_cont(jj,i))
5047               sqd2=dsqrt(d_cont(kk,i1))
5048               sred_geom = sqd1*sqd2
5049               IF (sred_geom.lt.cutoff_corr) THEN
5050                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5051      &            ekont,fprimcont)
5052 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5053 c     &         ' jj=',jj,' kk=',kk
5054                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5055                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5056                 do l=1,3
5057                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5058                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5059                 enddo
5060                 n_corr1=n_corr1+1
5061 cd               write (iout,*) 'sred_geom=',sred_geom,
5062 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5063                 call calc_eello(i,j,i+1,j1,jj,kk)
5064                 if (wcorr4.gt.0.0d0)
5065      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5066                 if (wcorr5.gt.0.0d0)
5067      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5068 c                print *,"wcorr5",ecorr5
5069 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5070 cd                write(2,*)'ijkl',i,j,i+1,j1
5071                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5072      &               .or. wturn6.eq.0.0d0))then
5073 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5074                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5075 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5076 cd     &            'ecorr6=',ecorr6
5077 cd                write (iout,'(4e15.5)') sred_geom,
5078 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5079 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5080 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5081                 else if (wturn6.gt.0.0d0
5082      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5083 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5084                   eturn6=eturn6+eello_turn6(i,jj,kk)
5085 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5086                 endif
5087               ENDIF
5088 1111          continue
5089             else if (j1.eq.j) then
5090 C Contacts I-J and I-(J+1) occur simultaneously.
5091 C The system loses extra energy.
5092 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5093             endif
5094           enddo ! kk
5095           do kk=1,num_conti
5096             j1=jcont_hb(kk,i)
5097 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5098 c    &         ' jj=',jj,' kk=',kk
5099             if (j1.eq.j+1) then
5100 C Contacts I-J and (I+1)-J occur simultaneously.
5101 C The system loses extra energy.
5102 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5103             endif ! j1==j+1
5104           enddo ! kk
5105         enddo ! jj
5106       enddo ! i
5107       return
5108       end
5109 c------------------------------------------------------------------------------
5110       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5111       implicit real*8 (a-h,o-z)
5112       include 'DIMENSIONS'
5113       include 'COMMON.IOUNITS'
5114       include 'COMMON.DERIV'
5115       include 'COMMON.INTERACT'
5116       include 'COMMON.CONTACTS'
5117       double precision gx(3),gx1(3)
5118       logical lprn
5119       lprn=.false.
5120       eij=facont_hb(jj,i)
5121       ekl=facont_hb(kk,k)
5122       ees0pij=ees0p(jj,i)
5123       ees0pkl=ees0p(kk,k)
5124       ees0mij=ees0m(jj,i)
5125       ees0mkl=ees0m(kk,k)
5126       ekont=eij*ekl
5127       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5128 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5129 C Following 4 lines for diagnostics.
5130 cd    ees0pkl=0.0D0
5131 cd    ees0pij=1.0D0
5132 cd    ees0mkl=0.0D0
5133 cd    ees0mij=1.0D0
5134 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5135 c    &   ' and',k,l
5136 c     write (iout,*)'Contacts have occurred for peptide groups',
5137 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5138 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5139 C Calculate the multi-body contribution to energy.
5140       ecorr=ecorr+ekont*ees
5141       if (calc_grad) then
5142 C Calculate multi-body contributions to the gradient.
5143       do ll=1,3
5144         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5145         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5146      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5147      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5148         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5149      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5150      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5151         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5152         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5153      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5154      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5155         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5156      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5157      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5158       enddo
5159       do m=i+1,j-1
5160         do ll=1,3
5161           gradcorr(ll,m)=gradcorr(ll,m)+
5162      &     ees*ekl*gacont_hbr(ll,jj,i)-
5163      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5164      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5165         enddo
5166       enddo
5167       do m=k+1,l-1
5168         do ll=1,3
5169           gradcorr(ll,m)=gradcorr(ll,m)+
5170      &     ees*eij*gacont_hbr(ll,kk,k)-
5171      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5172      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5173         enddo
5174       enddo
5175       endif
5176       ehbcorr=ekont*ees
5177       return
5178       end
5179 C---------------------------------------------------------------------------
5180       subroutine dipole(i,j,jj)
5181       implicit real*8 (a-h,o-z)
5182       include 'DIMENSIONS'
5183       include 'sizesclu.dat'
5184       include 'COMMON.IOUNITS'
5185       include 'COMMON.CHAIN'
5186       include 'COMMON.FFIELD'
5187       include 'COMMON.DERIV'
5188       include 'COMMON.INTERACT'
5189       include 'COMMON.CONTACTS'
5190       include 'COMMON.TORSION'
5191       include 'COMMON.VAR'
5192       include 'COMMON.GEO'
5193       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5194      &  auxmat(2,2)
5195       iti1 = itortyp(itype(i+1))
5196       if (j.lt.nres-1) then
5197         itj1 = itortyp(itype(j+1))
5198       else
5199         itj1=ntortyp+1
5200       endif
5201       do iii=1,2
5202         dipi(iii,1)=Ub2(iii,i)
5203         dipderi(iii)=Ub2der(iii,i)
5204         dipi(iii,2)=b1(iii,iti1)
5205         dipj(iii,1)=Ub2(iii,j)
5206         dipderj(iii)=Ub2der(iii,j)
5207         dipj(iii,2)=b1(iii,itj1)
5208       enddo
5209       kkk=0
5210       do iii=1,2
5211         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5212         do jjj=1,2
5213           kkk=kkk+1
5214           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5215         enddo
5216       enddo
5217       if (.not.calc_grad) return
5218       do kkk=1,5
5219         do lll=1,3
5220           mmm=0
5221           do iii=1,2
5222             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5223      &        auxvec(1))
5224             do jjj=1,2
5225               mmm=mmm+1
5226               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5227             enddo
5228           enddo
5229         enddo
5230       enddo
5231       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5232       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5233       do iii=1,2
5234         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5235       enddo
5236       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5237       do iii=1,2
5238         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5239       enddo
5240       return
5241       end
5242 C---------------------------------------------------------------------------
5243       subroutine calc_eello(i,j,k,l,jj,kk)
5244 C
5245 C This subroutine computes matrices and vectors needed to calculate
5246 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5247 C
5248       implicit real*8 (a-h,o-z)
5249       include 'DIMENSIONS'
5250       include 'sizesclu.dat'
5251       include 'COMMON.IOUNITS'
5252       include 'COMMON.CHAIN'
5253       include 'COMMON.DERIV'
5254       include 'COMMON.INTERACT'
5255       include 'COMMON.CONTACTS'
5256       include 'COMMON.TORSION'
5257       include 'COMMON.VAR'
5258       include 'COMMON.GEO'
5259       include 'COMMON.FFIELD'
5260       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5261      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5262       logical lprn
5263       common /kutas/ lprn
5264 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5265 cd     & ' jj=',jj,' kk=',kk
5266 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5267       do iii=1,2
5268         do jjj=1,2
5269           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5270           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5271         enddo
5272       enddo
5273       call transpose2(aa1(1,1),aa1t(1,1))
5274       call transpose2(aa2(1,1),aa2t(1,1))
5275       do kkk=1,5
5276         do lll=1,3
5277           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5278      &      aa1tder(1,1,lll,kkk))
5279           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5280      &      aa2tder(1,1,lll,kkk))
5281         enddo
5282       enddo
5283       if (l.eq.j+1) then
5284 C parallel orientation of the two CA-CA-CA frames.
5285         if (i.gt.1) then
5286           iti=itortyp(itype(i))
5287         else
5288           iti=ntortyp+1
5289         endif
5290         itk1=itortyp(itype(k+1))
5291         itj=itortyp(itype(j))
5292         if (l.lt.nres-1) then
5293           itl1=itortyp(itype(l+1))
5294         else
5295           itl1=ntortyp+1
5296         endif
5297 C A1 kernel(j+1) A2T
5298 cd        do iii=1,2
5299 cd          write (iout,'(3f10.5,5x,3f10.5)')
5300 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5301 cd        enddo
5302         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5303      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5304      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5305 C Following matrices are needed only for 6-th order cumulants
5306         IF (wcorr6.gt.0.0d0) THEN
5307         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5308      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5309      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5310         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5311      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5312      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5313      &   ADtEAderx(1,1,1,1,1,1))
5314         lprn=.false.
5315         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5316      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5317      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5318      &   ADtEA1derx(1,1,1,1,1,1))
5319         ENDIF
5320 C End 6-th order cumulants
5321 cd        lprn=.false.
5322 cd        if (lprn) then
5323 cd        write (2,*) 'In calc_eello6'
5324 cd        do iii=1,2
5325 cd          write (2,*) 'iii=',iii
5326 cd          do kkk=1,5
5327 cd            write (2,*) 'kkk=',kkk
5328 cd            do jjj=1,2
5329 cd              write (2,'(3(2f10.5),5x)')
5330 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5331 cd            enddo
5332 cd          enddo
5333 cd        enddo
5334 cd        endif
5335         call transpose2(EUgder(1,1,k),auxmat(1,1))
5336         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5337         call transpose2(EUg(1,1,k),auxmat(1,1))
5338         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5339         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5340         do iii=1,2
5341           do kkk=1,5
5342             do lll=1,3
5343               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5344      &          EAEAderx(1,1,lll,kkk,iii,1))
5345             enddo
5346           enddo
5347         enddo
5348 C A1T kernel(i+1) A2
5349         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5350      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5351      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5352 C Following matrices are needed only for 6-th order cumulants
5353         IF (wcorr6.gt.0.0d0) THEN
5354         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5355      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5356      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5357         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5358      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
5359      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5360      &   ADtEAderx(1,1,1,1,1,2))
5361         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5362      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5363      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5364      &   ADtEA1derx(1,1,1,1,1,2))
5365         ENDIF
5366 C End 6-th order cumulants
5367         call transpose2(EUgder(1,1,l),auxmat(1,1))
5368         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5369         call transpose2(EUg(1,1,l),auxmat(1,1))
5370         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5371         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5372         do iii=1,2
5373           do kkk=1,5
5374             do lll=1,3
5375               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5376      &          EAEAderx(1,1,lll,kkk,iii,2))
5377             enddo
5378           enddo
5379         enddo
5380 C AEAb1 and AEAb2
5381 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5382 C They are needed only when the fifth- or the sixth-order cumulants are
5383 C indluded.
5384         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5385         call transpose2(AEA(1,1,1),auxmat(1,1))
5386         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5387         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5388         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5389         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5390         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5391         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5392         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5393         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5394         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5395         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5396         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5397         call transpose2(AEA(1,1,2),auxmat(1,1))
5398         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5399         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5400         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5401         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5402         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5403         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5404         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5405         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5406         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5407         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5408         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5409 C Calculate the Cartesian derivatives of the vectors.
5410         do iii=1,2
5411           do kkk=1,5
5412             do lll=1,3
5413               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5414               call matvec2(auxmat(1,1),b1(1,iti),
5415      &          AEAb1derx(1,lll,kkk,iii,1,1))
5416               call matvec2(auxmat(1,1),Ub2(1,i),
5417      &          AEAb2derx(1,lll,kkk,iii,1,1))
5418               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5419      &          AEAb1derx(1,lll,kkk,iii,2,1))
5420               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5421      &          AEAb2derx(1,lll,kkk,iii,2,1))
5422               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5423               call matvec2(auxmat(1,1),b1(1,itj),
5424      &          AEAb1derx(1,lll,kkk,iii,1,2))
5425               call matvec2(auxmat(1,1),Ub2(1,j),
5426      &          AEAb2derx(1,lll,kkk,iii,1,2))
5427               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
5428      &          AEAb1derx(1,lll,kkk,iii,2,2))
5429               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
5430      &          AEAb2derx(1,lll,kkk,iii,2,2))
5431             enddo
5432           enddo
5433         enddo
5434         ENDIF
5435 C End vectors
5436       else
5437 C Antiparallel orientation of the two CA-CA-CA frames.
5438         if (i.gt.1) then
5439           iti=itortyp(itype(i))
5440         else
5441           iti=ntortyp+1
5442         endif
5443         itk1=itortyp(itype(k+1))
5444         itl=itortyp(itype(l))
5445         itj=itortyp(itype(j))
5446         if (j.lt.nres-1) then
5447           itj1=itortyp(itype(j+1))
5448         else
5449           itj1=ntortyp+1
5450         endif
5451 C A2 kernel(j-1)T A1T
5452         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5453      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
5454      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5455 C Following matrices are needed only for 6-th order cumulants
5456         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5457      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5458         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5459      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
5460      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5461         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5462      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
5463      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5464      &   ADtEAderx(1,1,1,1,1,1))
5465         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5466      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
5467      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5468      &   ADtEA1derx(1,1,1,1,1,1))
5469         ENDIF
5470 C End 6-th order cumulants
5471         call transpose2(EUgder(1,1,k),auxmat(1,1))
5472         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5473         call transpose2(EUg(1,1,k),auxmat(1,1))
5474         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5475         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5476         do iii=1,2
5477           do kkk=1,5
5478             do lll=1,3
5479               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5480      &          EAEAderx(1,1,lll,kkk,iii,1))
5481             enddo
5482           enddo
5483         enddo
5484 C A2T kernel(i+1)T A1
5485         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5486      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
5487      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5488 C Following matrices are needed only for 6-th order cumulants
5489         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5490      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5491         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5492      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
5493      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5494         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5495      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
5496      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5497      &   ADtEAderx(1,1,1,1,1,2))
5498         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5499      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
5500      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5501      &   ADtEA1derx(1,1,1,1,1,2))
5502         ENDIF
5503 C End 6-th order cumulants
5504         call transpose2(EUgder(1,1,j),auxmat(1,1))
5505         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
5506         call transpose2(EUg(1,1,j),auxmat(1,1))
5507         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5508         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5509         do iii=1,2
5510           do kkk=1,5
5511             do lll=1,3
5512               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5513      &          EAEAderx(1,1,lll,kkk,iii,2))
5514             enddo
5515           enddo
5516         enddo
5517 C AEAb1 and AEAb2
5518 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5519 C They are needed only when the fifth- or the sixth-order cumulants are
5520 C indluded.
5521         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
5522      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
5523         call transpose2(AEA(1,1,1),auxmat(1,1))
5524         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5525         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5526         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5527         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5528         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5529         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5530         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5531         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5532         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5533         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5534         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5535         call transpose2(AEA(1,1,2),auxmat(1,1))
5536         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
5537         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
5538         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
5539         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5540         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
5541         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
5542         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
5543         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
5544         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
5545         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
5546         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
5547 C Calculate the Cartesian derivatives of the vectors.
5548         do iii=1,2
5549           do kkk=1,5
5550             do lll=1,3
5551               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5552               call matvec2(auxmat(1,1),b1(1,iti),
5553      &          AEAb1derx(1,lll,kkk,iii,1,1))
5554               call matvec2(auxmat(1,1),Ub2(1,i),
5555      &          AEAb2derx(1,lll,kkk,iii,1,1))
5556               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5557      &          AEAb1derx(1,lll,kkk,iii,2,1))
5558               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5559      &          AEAb2derx(1,lll,kkk,iii,2,1))
5560               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5561               call matvec2(auxmat(1,1),b1(1,itl),
5562      &          AEAb1derx(1,lll,kkk,iii,1,2))
5563               call matvec2(auxmat(1,1),Ub2(1,l),
5564      &          AEAb2derx(1,lll,kkk,iii,1,2))
5565               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
5566      &          AEAb1derx(1,lll,kkk,iii,2,2))
5567               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
5568      &          AEAb2derx(1,lll,kkk,iii,2,2))
5569             enddo
5570           enddo
5571         enddo
5572         ENDIF
5573 C End vectors
5574       endif
5575       return
5576       end
5577 C---------------------------------------------------------------------------
5578       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
5579      &  KK,KKderg,AKA,AKAderg,AKAderx)
5580       implicit none
5581       integer nderg
5582       logical transp
5583       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
5584      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
5585      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
5586       integer iii,kkk,lll
5587       integer jjj,mmm
5588       logical lprn
5589       common /kutas/ lprn
5590       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
5591       do iii=1,nderg
5592         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
5593      &    AKAderg(1,1,iii))
5594       enddo
5595 cd      if (lprn) write (2,*) 'In kernel'
5596       do kkk=1,5
5597 cd        if (lprn) write (2,*) 'kkk=',kkk
5598         do lll=1,3
5599           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
5600      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
5601 cd          if (lprn) then
5602 cd            write (2,*) 'lll=',lll
5603 cd            write (2,*) 'iii=1'
5604 cd            do jjj=1,2
5605 cd              write (2,'(3(2f10.5),5x)')
5606 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
5607 cd            enddo
5608 cd          endif
5609           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
5610      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
5611 cd          if (lprn) then
5612 cd            write (2,*) 'lll=',lll
5613 cd            write (2,*) 'iii=2'
5614 cd            do jjj=1,2
5615 cd              write (2,'(3(2f10.5),5x)')
5616 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
5617 cd            enddo
5618 cd          endif
5619         enddo
5620       enddo
5621       return
5622       end
5623 C---------------------------------------------------------------------------
5624       double precision function eello4(i,j,k,l,jj,kk)
5625       implicit real*8 (a-h,o-z)
5626       include 'DIMENSIONS'
5627       include 'sizesclu.dat'
5628       include 'COMMON.IOUNITS'
5629       include 'COMMON.CHAIN'
5630       include 'COMMON.DERIV'
5631       include 'COMMON.INTERACT'
5632       include 'COMMON.CONTACTS'
5633       include 'COMMON.TORSION'
5634       include 'COMMON.VAR'
5635       include 'COMMON.GEO'
5636       double precision pizda(2,2),ggg1(3),ggg2(3)
5637 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
5638 cd        eello4=0.0d0
5639 cd        return
5640 cd      endif
5641 cd      print *,'eello4:',i,j,k,l,jj,kk
5642 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
5643 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
5644 cold      eij=facont_hb(jj,i)
5645 cold      ekl=facont_hb(kk,k)
5646 cold      ekont=eij*ekl
5647       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
5648       if (calc_grad) then
5649 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
5650       gcorr_loc(k-1)=gcorr_loc(k-1)
5651      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
5652       if (l.eq.j+1) then
5653         gcorr_loc(l-1)=gcorr_loc(l-1)
5654      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5655       else
5656         gcorr_loc(j-1)=gcorr_loc(j-1)
5657      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5658       endif
5659       do iii=1,2
5660         do kkk=1,5
5661           do lll=1,3
5662             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
5663      &                        -EAEAderx(2,2,lll,kkk,iii,1)
5664 cd            derx(lll,kkk,iii)=0.0d0
5665           enddo
5666         enddo
5667       enddo
5668 cd      gcorr_loc(l-1)=0.0d0
5669 cd      gcorr_loc(j-1)=0.0d0
5670 cd      gcorr_loc(k-1)=0.0d0
5671 cd      eel4=1.0d0
5672 cd      write (iout,*)'Contacts have occurred for peptide groups',
5673 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
5674 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
5675       if (j.lt.nres-1) then
5676         j1=j+1
5677         j2=j-1
5678       else
5679         j1=j-1
5680         j2=j-2
5681       endif
5682       if (l.lt.nres-1) then
5683         l1=l+1
5684         l2=l-1
5685       else
5686         l1=l-1
5687         l2=l-2
5688       endif
5689       do ll=1,3
5690 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
5691         ggg1(ll)=eel4*g_contij(ll,1)
5692         ggg2(ll)=eel4*g_contij(ll,2)
5693         ghalf=0.5d0*ggg1(ll)
5694 cd        ghalf=0.0d0
5695         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
5696         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
5697         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
5698         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
5699 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
5700         ghalf=0.5d0*ggg2(ll)
5701 cd        ghalf=0.0d0
5702         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
5703         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
5704         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
5705         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
5706       enddo
5707 cd      goto 1112
5708       do m=i+1,j-1
5709         do ll=1,3
5710 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
5711           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
5712         enddo
5713       enddo
5714       do m=k+1,l-1
5715         do ll=1,3
5716 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
5717           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
5718         enddo
5719       enddo
5720 1112  continue
5721       do m=i+2,j2
5722         do ll=1,3
5723           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
5724         enddo
5725       enddo
5726       do m=k+2,l2
5727         do ll=1,3
5728           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
5729         enddo
5730       enddo
5731 cd      do iii=1,nres-3
5732 cd        write (2,*) iii,gcorr_loc(iii)
5733 cd      enddo
5734       endif
5735       eello4=ekont*eel4
5736 cd      write (2,*) 'ekont',ekont
5737 cd      write (iout,*) 'eello4',ekont*eel4
5738       return
5739       end
5740 C---------------------------------------------------------------------------
5741       double precision function eello5(i,j,k,l,jj,kk)
5742       implicit real*8 (a-h,o-z)
5743       include 'DIMENSIONS'
5744       include 'sizesclu.dat'
5745       include 'COMMON.IOUNITS'
5746       include 'COMMON.CHAIN'
5747       include 'COMMON.DERIV'
5748       include 'COMMON.INTERACT'
5749       include 'COMMON.CONTACTS'
5750       include 'COMMON.TORSION'
5751       include 'COMMON.VAR'
5752       include 'COMMON.GEO'
5753       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
5754       double precision ggg1(3),ggg2(3)
5755 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5756 C                                                                              C
5757 C                            Parallel chains                                   C
5758 C                                                                              C
5759 C          o             o                   o             o                   C
5760 C         /l\           / \             \   / \           / \   /              C
5761 C        /   \         /   \             \ /   \         /   \ /               C
5762 C       j| o |l1       | o |              o| o |         | o |o                C
5763 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
5764 C      \i/   \         /   \ /             /   \         /   \                 C
5765 C       o    k1             o                                                  C
5766 C         (I)          (II)                (III)          (IV)                 C
5767 C                                                                              C
5768 C      eello5_1        eello5_2            eello5_3       eello5_4             C
5769 C                                                                              C
5770 C                            Antiparallel chains                               C
5771 C                                                                              C
5772 C          o             o                   o             o                   C
5773 C         /j\           / \             \   / \           / \   /              C
5774 C        /   \         /   \             \ /   \         /   \ /               C
5775 C      j1| o |l        | o |              o| o |         | o |o                C
5776 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
5777 C      \i/   \         /   \ /             /   \         /   \                 C
5778 C       o     k1            o                                                  C
5779 C         (I)          (II)                (III)          (IV)                 C
5780 C                                                                              C
5781 C      eello5_1        eello5_2            eello5_3       eello5_4             C
5782 C                                                                              C
5783 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
5784 C                                                                              C
5785 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5786 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
5787 cd        eello5=0.0d0
5788 cd        return
5789 cd      endif
5790 cd      write (iout,*)
5791 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
5792 cd     &   ' and',k,l
5793       itk=itortyp(itype(k))
5794       itl=itortyp(itype(l))
5795       itj=itortyp(itype(j))
5796       eello5_1=0.0d0
5797       eello5_2=0.0d0
5798       eello5_3=0.0d0
5799       eello5_4=0.0d0
5800 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
5801 cd     &   eel5_3_num,eel5_4_num)
5802       do iii=1,2
5803         do kkk=1,5
5804           do lll=1,3
5805             derx(lll,kkk,iii)=0.0d0
5806           enddo
5807         enddo
5808       enddo
5809 cd      eij=facont_hb(jj,i)
5810 cd      ekl=facont_hb(kk,k)
5811 cd      ekont=eij*ekl
5812 cd      write (iout,*)'Contacts have occurred for peptide groups',
5813 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
5814 cd      goto 1111
5815 C Contribution from the graph I.
5816 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
5817 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
5818       call transpose2(EUg(1,1,k),auxmat(1,1))
5819       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
5820       vv(1)=pizda(1,1)-pizda(2,2)
5821       vv(2)=pizda(1,2)+pizda(2,1)
5822       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
5823      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
5824       if (calc_grad) then
5825 C Explicit gradient in virtual-dihedral angles.
5826       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
5827      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
5828      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
5829       call transpose2(EUgder(1,1,k),auxmat1(1,1))
5830       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
5831       vv(1)=pizda(1,1)-pizda(2,2)
5832       vv(2)=pizda(1,2)+pizda(2,1)
5833       g_corr5_loc(k-1)=g_corr5_loc(k-1)
5834      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
5835      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5836       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
5837       vv(1)=pizda(1,1)-pizda(2,2)
5838       vv(2)=pizda(1,2)+pizda(2,1)
5839       if (l.eq.j+1) then
5840         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
5841      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
5842      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5843       else
5844         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
5845      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
5846      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5847       endif
5848 C Cartesian gradient
5849       do iii=1,2
5850         do kkk=1,5
5851           do lll=1,3
5852             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
5853      &        pizda(1,1))
5854             vv(1)=pizda(1,1)-pizda(2,2)
5855             vv(2)=pizda(1,2)+pizda(2,1)
5856             derx(lll,kkk,iii)=derx(lll,kkk,iii)
5857      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
5858      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
5859           enddo
5860         enddo
5861       enddo
5862 c      goto 1112
5863       endif
5864 c1111  continue
5865 C Contribution from graph II
5866       call transpose2(EE(1,1,itk),auxmat(1,1))
5867       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
5868       vv(1)=pizda(1,1)+pizda(2,2)
5869       vv(2)=pizda(2,1)-pizda(1,2)
5870       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
5871      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
5872       if (calc_grad) then
5873 C Explicit gradient in virtual-dihedral angles.
5874       g_corr5_loc(k-1)=g_corr5_loc(k-1)
5875      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
5876       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
5877       vv(1)=pizda(1,1)+pizda(2,2)
5878       vv(2)=pizda(2,1)-pizda(1,2)
5879       if (l.eq.j+1) then
5880         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5881      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
5882      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
5883       else
5884         g_corr5_loc(j-1)=g_corr5_loc(j-1)
5885      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
5886      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
5887       endif
5888 C Cartesian gradient
5889       do iii=1,2
5890         do kkk=1,5
5891           do lll=1,3
5892             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5893      &        pizda(1,1))
5894             vv(1)=pizda(1,1)+pizda(2,2)
5895             vv(2)=pizda(2,1)-pizda(1,2)
5896             derx(lll,kkk,iii)=derx(lll,kkk,iii)
5897      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
5898      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
5899           enddo
5900         enddo
5901       enddo
5902 cd      goto 1112
5903       endif
5904 cd1111  continue
5905       if (l.eq.j+1) then
5906 cd        goto 1110
5907 C Parallel orientation
5908 C Contribution from graph III
5909         call transpose2(EUg(1,1,l),auxmat(1,1))
5910         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
5911         vv(1)=pizda(1,1)-pizda(2,2)
5912         vv(2)=pizda(1,2)+pizda(2,1)
5913         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
5914      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
5915         if (calc_grad) then
5916 C Explicit gradient in virtual-dihedral angles.
5917         g_corr5_loc(j-1)=g_corr5_loc(j-1)
5918      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
5919      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
5920         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
5921         vv(1)=pizda(1,1)-pizda(2,2)
5922         vv(2)=pizda(1,2)+pizda(2,1)
5923         g_corr5_loc(k-1)=g_corr5_loc(k-1)
5924      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
5925      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
5926         call transpose2(EUgder(1,1,l),auxmat1(1,1))
5927         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
5928         vv(1)=pizda(1,1)-pizda(2,2)
5929         vv(2)=pizda(1,2)+pizda(2,1)
5930         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5931      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
5932      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
5933 C Cartesian gradient
5934         do iii=1,2
5935           do kkk=1,5
5936             do lll=1,3
5937               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
5938      &          pizda(1,1))
5939               vv(1)=pizda(1,1)-pizda(2,2)
5940               vv(2)=pizda(1,2)+pizda(2,1)
5941               derx(lll,kkk,iii)=derx(lll,kkk,iii)
5942      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
5943      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
5944             enddo
5945           enddo
5946         enddo
5947 cd        goto 1112
5948         endif
5949 C Contribution from graph IV
5950 cd1110    continue
5951         call transpose2(EE(1,1,itl),auxmat(1,1))
5952         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
5953         vv(1)=pizda(1,1)+pizda(2,2)
5954         vv(2)=pizda(2,1)-pizda(1,2)
5955         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
5956      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
5957         if (calc_grad) then
5958 C Explicit gradient in virtual-dihedral angles.
5959         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5960      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
5961         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
5962         vv(1)=pizda(1,1)+pizda(2,2)
5963         vv(2)=pizda(2,1)-pizda(1,2)
5964         g_corr5_loc(k-1)=g_corr5_loc(k-1)
5965      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
5966      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
5967 C Cartesian gradient
5968         do iii=1,2
5969           do kkk=1,5
5970             do lll=1,3
5971               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5972      &          pizda(1,1))
5973               vv(1)=pizda(1,1)+pizda(2,2)
5974               vv(2)=pizda(2,1)-pizda(1,2)
5975               derx(lll,kkk,iii)=derx(lll,kkk,iii)
5976      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
5977      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
5978             enddo
5979           enddo
5980         enddo
5981         endif
5982       else
5983 C Antiparallel orientation
5984 C Contribution from graph III
5985 c        goto 1110
5986         call transpose2(EUg(1,1,j),auxmat(1,1))
5987         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
5988         vv(1)=pizda(1,1)-pizda(2,2)
5989         vv(2)=pizda(1,2)+pizda(2,1)
5990         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
5991      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
5992         if (calc_grad) then
5993 C Explicit gradient in virtual-dihedral angles.
5994         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5995      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
5996      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
5997         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
5998         vv(1)=pizda(1,1)-pizda(2,2)
5999         vv(2)=pizda(1,2)+pizda(2,1)
6000         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6001      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6002      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6003         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6004         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6005         vv(1)=pizda(1,1)-pizda(2,2)
6006         vv(2)=pizda(1,2)+pizda(2,1)
6007         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6008      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6009      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6010 C Cartesian gradient
6011         do iii=1,2
6012           do kkk=1,5
6013             do lll=1,3
6014               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6015      &          pizda(1,1))
6016               vv(1)=pizda(1,1)-pizda(2,2)
6017               vv(2)=pizda(1,2)+pizda(2,1)
6018               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6019      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6020      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6021             enddo
6022           enddo
6023         enddo
6024 cd        goto 1112
6025         endif
6026 C Contribution from graph IV
6027 1110    continue
6028         call transpose2(EE(1,1,itj),auxmat(1,1))
6029         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6030         vv(1)=pizda(1,1)+pizda(2,2)
6031         vv(2)=pizda(2,1)-pizda(1,2)
6032         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6033      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6034         if (calc_grad) then
6035 C Explicit gradient in virtual-dihedral angles.
6036         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6037      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6038         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6039         vv(1)=pizda(1,1)+pizda(2,2)
6040         vv(2)=pizda(2,1)-pizda(1,2)
6041         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6042      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6043      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6044 C Cartesian gradient
6045         do iii=1,2
6046           do kkk=1,5
6047             do lll=1,3
6048               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6049      &          pizda(1,1))
6050               vv(1)=pizda(1,1)+pizda(2,2)
6051               vv(2)=pizda(2,1)-pizda(1,2)
6052               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6053      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6054      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6055             enddo
6056           enddo
6057         enddo
6058       endif
6059       endif
6060 1112  continue
6061       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6062 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6063 cd        write (2,*) 'ijkl',i,j,k,l
6064 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6065 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6066 cd      endif
6067 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6068 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6069 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6070 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6071       if (calc_grad) then
6072       if (j.lt.nres-1) then
6073         j1=j+1
6074         j2=j-1
6075       else
6076         j1=j-1
6077         j2=j-2
6078       endif
6079       if (l.lt.nres-1) then
6080         l1=l+1
6081         l2=l-1
6082       else
6083         l1=l-1
6084         l2=l-2
6085       endif
6086 cd      eij=1.0d0
6087 cd      ekl=1.0d0
6088 cd      ekont=1.0d0
6089 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6090       do ll=1,3
6091         ggg1(ll)=eel5*g_contij(ll,1)
6092         ggg2(ll)=eel5*g_contij(ll,2)
6093 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6094         ghalf=0.5d0*ggg1(ll)
6095 cd        ghalf=0.0d0
6096         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6097         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6098         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6099         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6100 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6101         ghalf=0.5d0*ggg2(ll)
6102 cd        ghalf=0.0d0
6103         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6104         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6105         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6106         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6107       enddo
6108 cd      goto 1112
6109       do m=i+1,j-1
6110         do ll=1,3
6111 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6112           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6113         enddo
6114       enddo
6115       do m=k+1,l-1
6116         do ll=1,3
6117 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6118           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6119         enddo
6120       enddo
6121 c1112  continue
6122       do m=i+2,j2
6123         do ll=1,3
6124           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6125         enddo
6126       enddo
6127       do m=k+2,l2
6128         do ll=1,3
6129           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6130         enddo
6131       enddo
6132 cd      do iii=1,nres-3
6133 cd        write (2,*) iii,g_corr5_loc(iii)
6134 cd      enddo
6135       endif
6136       eello5=ekont*eel5
6137 cd      write (2,*) 'ekont',ekont
6138 cd      write (iout,*) 'eello5',ekont*eel5
6139       return
6140       end
6141 c--------------------------------------------------------------------------
6142       double precision function eello6(i,j,k,l,jj,kk)
6143       implicit real*8 (a-h,o-z)
6144       include 'DIMENSIONS'
6145       include 'sizesclu.dat'
6146       include 'COMMON.IOUNITS'
6147       include 'COMMON.CHAIN'
6148       include 'COMMON.DERIV'
6149       include 'COMMON.INTERACT'
6150       include 'COMMON.CONTACTS'
6151       include 'COMMON.TORSION'
6152       include 'COMMON.VAR'
6153       include 'COMMON.GEO'
6154       include 'COMMON.FFIELD'
6155       double precision ggg1(3),ggg2(3)
6156 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6157 cd        eello6=0.0d0
6158 cd        return
6159 cd      endif
6160 cd      write (iout,*)
6161 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6162 cd     &   ' and',k,l
6163       eello6_1=0.0d0
6164       eello6_2=0.0d0
6165       eello6_3=0.0d0
6166       eello6_4=0.0d0
6167       eello6_5=0.0d0
6168       eello6_6=0.0d0
6169 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6170 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6171       do iii=1,2
6172         do kkk=1,5
6173           do lll=1,3
6174             derx(lll,kkk,iii)=0.0d0
6175           enddo
6176         enddo
6177       enddo
6178 cd      eij=facont_hb(jj,i)
6179 cd      ekl=facont_hb(kk,k)
6180 cd      ekont=eij*ekl
6181 cd      eij=1.0d0
6182 cd      ekl=1.0d0
6183 cd      ekont=1.0d0
6184       if (l.eq.j+1) then
6185         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6186         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6187         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6188         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6189         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6190         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6191       else
6192         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6193         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6194         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6195         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6196         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6197           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6198         else
6199           eello6_5=0.0d0
6200         endif
6201         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6202       endif
6203 C If turn contributions are considered, they will be handled separately.
6204       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6205 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6206 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6207 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6208 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6209 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6210 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6211 cd      goto 1112
6212       if (calc_grad) then
6213       if (j.lt.nres-1) then
6214         j1=j+1
6215         j2=j-1
6216       else
6217         j1=j-1
6218         j2=j-2
6219       endif
6220       if (l.lt.nres-1) then
6221         l1=l+1
6222         l2=l-1
6223       else
6224         l1=l-1
6225         l2=l-2
6226       endif
6227       do ll=1,3
6228         ggg1(ll)=eel6*g_contij(ll,1)
6229         ggg2(ll)=eel6*g_contij(ll,2)
6230 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6231         ghalf=0.5d0*ggg1(ll)
6232 cd        ghalf=0.0d0
6233         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6234         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6235         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6236         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6237         ghalf=0.5d0*ggg2(ll)
6238 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6239 cd        ghalf=0.0d0
6240         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6241         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6242         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6243         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6244       enddo
6245 cd      goto 1112
6246       do m=i+1,j-1
6247         do ll=1,3
6248 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6249           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6250         enddo
6251       enddo
6252       do m=k+1,l-1
6253         do ll=1,3
6254 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6255           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6256         enddo
6257       enddo
6258 1112  continue
6259       do m=i+2,j2
6260         do ll=1,3
6261           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6262         enddo
6263       enddo
6264       do m=k+2,l2
6265         do ll=1,3
6266           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6267         enddo
6268       enddo
6269 cd      do iii=1,nres-3
6270 cd        write (2,*) iii,g_corr6_loc(iii)
6271 cd      enddo
6272       endif
6273       eello6=ekont*eel6
6274 cd      write (2,*) 'ekont',ekont
6275 cd      write (iout,*) 'eello6',ekont*eel6
6276       return
6277       end
6278 c--------------------------------------------------------------------------
6279       double precision function eello6_graph1(i,j,k,l,imat,swap)
6280       implicit real*8 (a-h,o-z)
6281       include 'DIMENSIONS'
6282       include 'sizesclu.dat'
6283       include 'COMMON.IOUNITS'
6284       include 'COMMON.CHAIN'
6285       include 'COMMON.DERIV'
6286       include 'COMMON.INTERACT'
6287       include 'COMMON.CONTACTS'
6288       include 'COMMON.TORSION'
6289       include 'COMMON.VAR'
6290       include 'COMMON.GEO'
6291       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6292       logical swap
6293       logical lprn
6294       common /kutas/ lprn
6295 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6296 C                                                                              C
6297 C      Parallel       Antiparallel                                             C
6298 C                                                                              C
6299 C          o             o                                                     C
6300 C         /l\           /j\                                                    C
6301 C        /   \         /   \                                                   C
6302 C       /| o |         | o |\                                                  C
6303 C     \ j|/k\|  /   \  |/k\|l /                                                C
6304 C      \ /   \ /     \ /   \ /                                                 C
6305 C       o     o       o     o                                                  C
6306 C       i             i                                                        C
6307 C                                                                              C
6308 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6309       itk=itortyp(itype(k))
6310       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6311       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6312       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6313       call transpose2(EUgC(1,1,k),auxmat(1,1))
6314       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6315       vv1(1)=pizda1(1,1)-pizda1(2,2)
6316       vv1(2)=pizda1(1,2)+pizda1(2,1)
6317       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6318       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6319       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6320       s5=scalar2(vv(1),Dtobr2(1,i))
6321 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6322       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6323       if (.not. calc_grad) return
6324       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6325      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6326      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6327      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6328      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6329      & +scalar2(vv(1),Dtobr2der(1,i)))
6330       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6331       vv1(1)=pizda1(1,1)-pizda1(2,2)
6332       vv1(2)=pizda1(1,2)+pizda1(2,1)
6333       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6334       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6335       if (l.eq.j+1) then
6336         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6337      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6338      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6339      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6340      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6341       else
6342         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6343      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6344      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6345      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6346      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6347       endif
6348       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6349       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6350       vv1(1)=pizda1(1,1)-pizda1(2,2)
6351       vv1(2)=pizda1(1,2)+pizda1(2,1)
6352       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6353      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6354      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6355      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6356       do iii=1,2
6357         if (swap) then
6358           ind=3-iii
6359         else
6360           ind=iii
6361         endif
6362         do kkk=1,5
6363           do lll=1,3
6364             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6365             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6366             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6367             call transpose2(EUgC(1,1,k),auxmat(1,1))
6368             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6369      &        pizda1(1,1))
6370             vv1(1)=pizda1(1,1)-pizda1(2,2)
6371             vv1(2)=pizda1(1,2)+pizda1(2,1)
6372             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6373             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6374      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6375             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6376      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6377             s5=scalar2(vv(1),Dtobr2(1,i))
6378             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6379           enddo
6380         enddo
6381       enddo
6382       return
6383       end
6384 c----------------------------------------------------------------------------
6385       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6386       implicit real*8 (a-h,o-z)
6387       include 'DIMENSIONS'
6388       include 'sizesclu.dat'
6389       include 'COMMON.IOUNITS'
6390       include 'COMMON.CHAIN'
6391       include 'COMMON.DERIV'
6392       include 'COMMON.INTERACT'
6393       include 'COMMON.CONTACTS'
6394       include 'COMMON.TORSION'
6395       include 'COMMON.VAR'
6396       include 'COMMON.GEO'
6397       logical swap
6398       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6399      & auxvec1(2),auxvec2(2),auxmat1(2,2)
6400       logical lprn
6401       common /kutas/ lprn
6402 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6403 C                                                                              C
6404 C      Parallel       Antiparallel                                             C
6405 C                                                                              C
6406 C          o             o                                                     C
6407 C     \   /l\           /j\   /                                                C
6408 C      \ /   \         /   \ /                                                 C
6409 C       o| o |         | o |o                                                  C
6410 C     \ j|/k\|      \  |/k\|l                                                  C
6411 C      \ /   \       \ /   \                                                   C
6412 C       o             o                                                        C
6413 C       i             i                                                        C
6414 C                                                                              C
6415 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6416 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6417 C AL 7/4/01 s1 would occur in the sixth-order moment,
6418 C           but not in a cluster cumulant
6419 #ifdef MOMENT
6420       s1=dip(1,jj,i)*dip(1,kk,k)
6421 #endif
6422       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
6423       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6424       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
6425       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
6426       call transpose2(EUg(1,1,k),auxmat(1,1))
6427       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
6428       vv(1)=pizda(1,1)-pizda(2,2)
6429       vv(2)=pizda(1,2)+pizda(2,1)
6430       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6431 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6432 #ifdef MOMENT
6433       eello6_graph2=-(s1+s2+s3+s4)
6434 #else
6435       eello6_graph2=-(s2+s3+s4)
6436 #endif
6437 c      eello6_graph2=-s3
6438       if (.not. calc_grad) return
6439 C Derivatives in gamma(i-1)
6440       if (i.gt.1) then
6441 #ifdef MOMENT
6442         s1=dipderg(1,jj,i)*dip(1,kk,k)
6443 #endif
6444         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6445         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
6446         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6447         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6448 #ifdef MOMENT
6449         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6450 #else
6451         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6452 #endif
6453 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
6454       endif
6455 C Derivatives in gamma(k-1)
6456 #ifdef MOMENT
6457       s1=dip(1,jj,i)*dipderg(1,kk,k)
6458 #endif
6459       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
6460       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6461       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
6462       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6463       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6464       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
6465       vv(1)=pizda(1,1)-pizda(2,2)
6466       vv(2)=pizda(1,2)+pizda(2,1)
6467       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6468 #ifdef MOMENT
6469       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6470 #else
6471       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6472 #endif
6473 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
6474 C Derivatives in gamma(j-1) or gamma(l-1)
6475       if (j.gt.1) then
6476 #ifdef MOMENT
6477         s1=dipderg(3,jj,i)*dip(1,kk,k)
6478 #endif
6479         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
6480         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6481         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
6482         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
6483         vv(1)=pizda(1,1)-pizda(2,2)
6484         vv(2)=pizda(1,2)+pizda(2,1)
6485         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6486 #ifdef MOMENT
6487         if (swap) then
6488           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6489         else
6490           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6491         endif
6492 #endif
6493         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
6494 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
6495       endif
6496 C Derivatives in gamma(l-1) or gamma(j-1)
6497       if (l.gt.1) then
6498 #ifdef MOMENT
6499         s1=dip(1,jj,i)*dipderg(3,kk,k)
6500 #endif
6501         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
6502         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6503         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
6504         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6505         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
6506         vv(1)=pizda(1,1)-pizda(2,2)
6507         vv(2)=pizda(1,2)+pizda(2,1)
6508         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6509 #ifdef MOMENT
6510         if (swap) then
6511           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6512         else
6513           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6514         endif
6515 #endif
6516         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
6517 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
6518       endif
6519 C Cartesian derivatives.
6520       if (lprn) then
6521         write (2,*) 'In eello6_graph2'
6522         do iii=1,2
6523           write (2,*) 'iii=',iii
6524           do kkk=1,5
6525             write (2,*) 'kkk=',kkk
6526             do jjj=1,2
6527               write (2,'(3(2f10.5),5x)')
6528      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6529             enddo
6530           enddo
6531         enddo
6532       endif
6533       do iii=1,2
6534         do kkk=1,5
6535           do lll=1,3
6536 #ifdef MOMENT
6537             if (iii.eq.1) then
6538               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
6539             else
6540               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
6541             endif
6542 #endif
6543             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
6544      &        auxvec(1))
6545             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6546             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
6547      &        auxvec(1))
6548             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
6549             call transpose2(EUg(1,1,k),auxmat(1,1))
6550             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
6551      &        pizda(1,1))
6552             vv(1)=pizda(1,1)-pizda(2,2)
6553             vv(2)=pizda(1,2)+pizda(2,1)
6554             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6555 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
6556 #ifdef MOMENT
6557             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6558 #else
6559             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6560 #endif
6561             if (swap) then
6562               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6563             else
6564               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6565             endif
6566           enddo
6567         enddo
6568       enddo
6569       return
6570       end
6571 c----------------------------------------------------------------------------
6572       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
6573       implicit real*8 (a-h,o-z)
6574       include 'DIMENSIONS'
6575       include 'sizesclu.dat'
6576       include 'COMMON.IOUNITS'
6577       include 'COMMON.CHAIN'
6578       include 'COMMON.DERIV'
6579       include 'COMMON.INTERACT'
6580       include 'COMMON.CONTACTS'
6581       include 'COMMON.TORSION'
6582       include 'COMMON.VAR'
6583       include 'COMMON.GEO'
6584       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
6585       logical swap
6586 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6587 C                                                                              C
6588 C      Parallel       Antiparallel                                             C
6589 C                                                                              C
6590 C          o             o                                                     C
6591 C         /l\   /   \   /j\                                                    C
6592 C        /   \ /     \ /   \                                                   C
6593 C       /| o |o       o| o |\                                                  C
6594 C       j|/k\|  /      |/k\|l /                                                C
6595 C        /   \ /       /   \ /                                                 C
6596 C       /     o       /     o                                                  C
6597 C       i             i                                                        C
6598 C                                                                              C
6599 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6600 C
6601 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6602 C           energy moment and not to the cluster cumulant.
6603       iti=itortyp(itype(i))
6604       if (j.lt.nres-1) then
6605         itj1=itortyp(itype(j+1))
6606       else
6607         itj1=ntortyp+1
6608       endif
6609       itk=itortyp(itype(k))
6610       itk1=itortyp(itype(k+1))
6611       if (l.lt.nres-1) then
6612         itl1=itortyp(itype(l+1))
6613       else
6614         itl1=ntortyp+1
6615       endif
6616 #ifdef MOMENT
6617       s1=dip(4,jj,i)*dip(4,kk,k)
6618 #endif
6619       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
6620       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6621       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
6622       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6623       call transpose2(EE(1,1,itk),auxmat(1,1))
6624       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
6625       vv(1)=pizda(1,1)+pizda(2,2)
6626       vv(2)=pizda(2,1)-pizda(1,2)
6627       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6628 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6629 #ifdef MOMENT
6630       eello6_graph3=-(s1+s2+s3+s4)
6631 #else
6632       eello6_graph3=-(s2+s3+s4)
6633 #endif
6634 c      eello6_graph3=-s4
6635       if (.not. calc_grad) return
6636 C Derivatives in gamma(k-1)
6637       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
6638       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6639       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
6640       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
6641 C Derivatives in gamma(l-1)
6642       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
6643       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6644       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
6645       vv(1)=pizda(1,1)+pizda(2,2)
6646       vv(2)=pizda(2,1)-pizda(1,2)
6647       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6648       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6649 C Cartesian derivatives.
6650       do iii=1,2
6651         do kkk=1,5
6652           do lll=1,3
6653 #ifdef MOMENT
6654             if (iii.eq.1) then
6655               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
6656             else
6657               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
6658             endif
6659 #endif
6660             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6661      &        auxvec(1))
6662             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6663             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6664      &        auxvec(1))
6665             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6666             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
6667      &        pizda(1,1))
6668             vv(1)=pizda(1,1)+pizda(2,2)
6669             vv(2)=pizda(2,1)-pizda(1,2)
6670             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6671 #ifdef MOMENT
6672             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6673 #else
6674             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6675 #endif
6676             if (swap) then
6677               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6678             else
6679               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6680             endif
6681 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
6682           enddo
6683         enddo
6684       enddo
6685       return
6686       end
6687 c----------------------------------------------------------------------------
6688       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
6689       implicit real*8 (a-h,o-z)
6690       include 'DIMENSIONS'
6691       include 'sizesclu.dat'
6692       include 'COMMON.IOUNITS'
6693       include 'COMMON.CHAIN'
6694       include 'COMMON.DERIV'
6695       include 'COMMON.INTERACT'
6696       include 'COMMON.CONTACTS'
6697       include 'COMMON.TORSION'
6698       include 'COMMON.VAR'
6699       include 'COMMON.GEO'
6700       include 'COMMON.FFIELD'
6701       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6702      & auxvec1(2),auxmat1(2,2)
6703       logical swap
6704 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6705 C                                                                              C
6706 C      Parallel       Antiparallel                                             C
6707 C                                                                              C
6708 C          o             o                                                     C
6709 C         /l\   /   \   /j\                                                    C
6710 C        /   \ /     \ /   \                                                   C
6711 C       /| o |o       o| o |\                                                  C
6712 C     \ j|/k\|      \  |/k\|l                                                  C
6713 C      \ /   \       \ /   \                                                   C
6714 C       o     \       o     \                                                  C
6715 C       i             i                                                        C
6716 C                                                                              C
6717 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6718 C
6719 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6720 C           energy moment and not to the cluster cumulant.
6721 cd      write (2,*) 'eello_graph4: wturn6',wturn6
6722       iti=itortyp(itype(i))
6723       itj=itortyp(itype(j))
6724       if (j.lt.nres-1) then
6725         itj1=itortyp(itype(j+1))
6726       else
6727         itj1=ntortyp+1
6728       endif
6729       itk=itortyp(itype(k))
6730       if (k.lt.nres-1) then
6731         itk1=itortyp(itype(k+1))
6732       else
6733         itk1=ntortyp+1
6734       endif
6735       itl=itortyp(itype(l))
6736       if (l.lt.nres-1) then
6737         itl1=itortyp(itype(l+1))
6738       else
6739         itl1=ntortyp+1
6740       endif
6741 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
6742 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
6743 cd     & ' itl',itl,' itl1',itl1
6744 #ifdef MOMENT
6745       if (imat.eq.1) then
6746         s1=dip(3,jj,i)*dip(3,kk,k)
6747       else
6748         s1=dip(2,jj,j)*dip(2,kk,l)
6749       endif
6750 #endif
6751       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
6752       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6753       if (j.eq.l+1) then
6754         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
6755         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6756       else
6757         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
6758         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6759       endif
6760       call transpose2(EUg(1,1,k),auxmat(1,1))
6761       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
6762       vv(1)=pizda(1,1)-pizda(2,2)
6763       vv(2)=pizda(2,1)+pizda(1,2)
6764       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6765 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6766 #ifdef MOMENT
6767       eello6_graph4=-(s1+s2+s3+s4)
6768 #else
6769       eello6_graph4=-(s2+s3+s4)
6770 #endif
6771       if (.not. calc_grad) return
6772 C Derivatives in gamma(i-1)
6773       if (i.gt.1) then
6774 #ifdef MOMENT
6775         if (imat.eq.1) then
6776           s1=dipderg(2,jj,i)*dip(3,kk,k)
6777         else
6778           s1=dipderg(4,jj,j)*dip(2,kk,l)
6779         endif
6780 #endif
6781         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6782         if (j.eq.l+1) then
6783           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
6784           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6785         else
6786           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
6787           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6788         endif
6789         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6790         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6791 cd          write (2,*) 'turn6 derivatives'
6792 #ifdef MOMENT
6793           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
6794 #else
6795           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
6796 #endif
6797         else
6798 #ifdef MOMENT
6799           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6800 #else
6801           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6802 #endif
6803         endif
6804       endif
6805 C Derivatives in gamma(k-1)
6806 #ifdef MOMENT
6807       if (imat.eq.1) then
6808         s1=dip(3,jj,i)*dipderg(2,kk,k)
6809       else
6810         s1=dip(2,jj,j)*dipderg(4,kk,l)
6811       endif
6812 #endif
6813       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
6814       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
6815       if (j.eq.l+1) then
6816         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
6817         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6818       else
6819         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
6820         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6821       endif
6822       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6823       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
6824       vv(1)=pizda(1,1)-pizda(2,2)
6825       vv(2)=pizda(2,1)+pizda(1,2)
6826       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6827       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6828 #ifdef MOMENT
6829         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
6830 #else
6831         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
6832 #endif
6833       else
6834 #ifdef MOMENT
6835         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6836 #else
6837         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6838 #endif
6839       endif
6840 C Derivatives in gamma(j-1) or gamma(l-1)
6841       if (l.eq.j+1 .and. l.gt.1) then
6842         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
6843         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6844         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
6845         vv(1)=pizda(1,1)-pizda(2,2)
6846         vv(2)=pizda(2,1)+pizda(1,2)
6847         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6848         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6849       else if (j.gt.1) then
6850         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
6851         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6852         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
6853         vv(1)=pizda(1,1)-pizda(2,2)
6854         vv(2)=pizda(2,1)+pizda(1,2)
6855         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6856         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6857           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
6858         else
6859           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
6860         endif
6861       endif
6862 C Cartesian derivatives.
6863       do iii=1,2
6864         do kkk=1,5
6865           do lll=1,3
6866 #ifdef MOMENT
6867             if (iii.eq.1) then
6868               if (imat.eq.1) then
6869                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
6870               else
6871                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
6872               endif
6873             else
6874               if (imat.eq.1) then
6875                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
6876               else
6877                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
6878               endif
6879             endif
6880 #endif
6881             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
6882      &        auxvec(1))
6883             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6884             if (j.eq.l+1) then
6885               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
6886      &          b1(1,itj1),auxvec(1))
6887               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
6888             else
6889               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
6890      &          b1(1,itl1),auxvec(1))
6891               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
6892             endif
6893             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6894      &        pizda(1,1))
6895             vv(1)=pizda(1,1)-pizda(2,2)
6896             vv(2)=pizda(2,1)+pizda(1,2)
6897             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6898             if (swap) then
6899               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6900 #ifdef MOMENT
6901                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
6902      &             -(s1+s2+s4)
6903 #else
6904                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
6905      &             -(s2+s4)
6906 #endif
6907                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
6908               else
6909 #ifdef MOMENT
6910                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
6911 #else
6912                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
6913 #endif
6914                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6915               endif
6916             else
6917 #ifdef MOMENT
6918               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6919 #else
6920               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6921 #endif
6922               if (l.eq.j+1) then
6923                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6924               else
6925                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6926               endif
6927             endif
6928           enddo
6929         enddo
6930       enddo
6931       return
6932       end
6933 c----------------------------------------------------------------------------
6934       double precision function eello_turn6(i,jj,kk)
6935       implicit real*8 (a-h,o-z)
6936       include 'DIMENSIONS'
6937       include 'sizesclu.dat'
6938       include 'COMMON.IOUNITS'
6939       include 'COMMON.CHAIN'
6940       include 'COMMON.DERIV'
6941       include 'COMMON.INTERACT'
6942       include 'COMMON.CONTACTS'
6943       include 'COMMON.TORSION'
6944       include 'COMMON.VAR'
6945       include 'COMMON.GEO'
6946       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
6947      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
6948      &  ggg1(3),ggg2(3)
6949       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
6950      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
6951 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
6952 C           the respective energy moment and not to the cluster cumulant.
6953       eello_turn6=0.0d0
6954       j=i+4
6955       k=i+1
6956       l=i+3
6957       iti=itortyp(itype(i))
6958       itk=itortyp(itype(k))
6959       itk1=itortyp(itype(k+1))
6960       itl=itortyp(itype(l))
6961       itj=itortyp(itype(j))
6962 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
6963 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
6964 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6965 cd        eello6=0.0d0
6966 cd        return
6967 cd      endif
6968 cd      write (iout,*)
6969 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6970 cd     &   ' and',k,l
6971 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
6972       do iii=1,2
6973         do kkk=1,5
6974           do lll=1,3
6975             derx_turn(lll,kkk,iii)=0.0d0
6976           enddo
6977         enddo
6978       enddo
6979 cd      eij=1.0d0
6980 cd      ekl=1.0d0
6981 cd      ekont=1.0d0
6982       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6983 cd      eello6_5=0.0d0
6984 cd      write (2,*) 'eello6_5',eello6_5
6985 #ifdef MOMENT
6986       call transpose2(AEA(1,1,1),auxmat(1,1))
6987       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
6988       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
6989       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
6990 #else
6991       s1 = 0.0d0
6992 #endif
6993       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
6994       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
6995       s2 = scalar2(b1(1,itk),vtemp1(1))
6996 #ifdef MOMENT
6997       call transpose2(AEA(1,1,2),atemp(1,1))
6998       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
6999       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7000       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7001 #else
7002       s8=0.0d0
7003 #endif
7004       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7005       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7006       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7007 #ifdef MOMENT
7008       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7009       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7010       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7011       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7012       ss13 = scalar2(b1(1,itk),vtemp4(1))
7013       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7014 #else
7015       s13=0.0d0
7016 #endif
7017 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7018 c      s1=0.0d0
7019 c      s2=0.0d0
7020 c      s8=0.0d0
7021 c      s12=0.0d0
7022 c      s13=0.0d0
7023       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7024       if (calc_grad) then
7025 C Derivatives in gamma(i+2)
7026 #ifdef MOMENT
7027       call transpose2(AEA(1,1,1),auxmatd(1,1))
7028       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7029       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7030       call transpose2(AEAderg(1,1,2),atempd(1,1))
7031       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7032       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7033 #else
7034       s8d=0.0d0
7035 #endif
7036       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7037       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7038       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7039 c      s1d=0.0d0
7040 c      s2d=0.0d0
7041 c      s8d=0.0d0
7042 c      s12d=0.0d0
7043 c      s13d=0.0d0
7044       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7045 C Derivatives in gamma(i+3)
7046 #ifdef MOMENT
7047       call transpose2(AEA(1,1,1),auxmatd(1,1))
7048       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7049       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7050       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7051 #else
7052       s1d=0.0d0
7053 #endif
7054       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7055       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7056       s2d = scalar2(b1(1,itk),vtemp1d(1))
7057 #ifdef MOMENT
7058       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7059       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7060 #endif
7061       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7062 #ifdef MOMENT
7063       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7064       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7065       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7066 #else
7067       s13d=0.0d0
7068 #endif
7069 c      s1d=0.0d0
7070 c      s2d=0.0d0
7071 c      s8d=0.0d0
7072 c      s12d=0.0d0
7073 c      s13d=0.0d0
7074 #ifdef MOMENT
7075       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7076      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7077 #else
7078       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7079      &               -0.5d0*ekont*(s2d+s12d)
7080 #endif
7081 C Derivatives in gamma(i+4)
7082       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7083       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7084       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7085 #ifdef MOMENT
7086       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7087       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7088       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7089 #else
7090       s13d = 0.0d0
7091 #endif
7092 c      s1d=0.0d0
7093 c      s2d=0.0d0
7094 c      s8d=0.0d0
7095 C      s12d=0.0d0
7096 c      s13d=0.0d0
7097 #ifdef MOMENT
7098       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7099 #else
7100       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7101 #endif
7102 C Derivatives in gamma(i+5)
7103 #ifdef MOMENT
7104       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7105       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7106       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7107 #else
7108       s1d = 0.0d0
7109 #endif
7110       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7111       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7112       s2d = scalar2(b1(1,itk),vtemp1d(1))
7113 #ifdef MOMENT
7114       call transpose2(AEA(1,1,2),atempd(1,1))
7115       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7116       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7117 #else
7118       s8d = 0.0d0
7119 #endif
7120       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7121       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7122 #ifdef MOMENT
7123       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7124       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7125       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7126 #else
7127       s13d = 0.0d0
7128 #endif
7129 c      s1d=0.0d0
7130 c      s2d=0.0d0
7131 c      s8d=0.0d0
7132 c      s12d=0.0d0
7133 c      s13d=0.0d0
7134 #ifdef MOMENT
7135       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7136      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7137 #else
7138       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7139      &               -0.5d0*ekont*(s2d+s12d)
7140 #endif
7141 C Cartesian derivatives
7142       do iii=1,2
7143         do kkk=1,5
7144           do lll=1,3
7145 #ifdef MOMENT
7146             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7147             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7148             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7149 #else
7150             s1d = 0.0d0
7151 #endif
7152             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7153             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7154      &          vtemp1d(1))
7155             s2d = scalar2(b1(1,itk),vtemp1d(1))
7156 #ifdef MOMENT
7157             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7158             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7159             s8d = -(atempd(1,1)+atempd(2,2))*
7160      &           scalar2(cc(1,1,itl),vtemp2(1))
7161 #else
7162             s8d = 0.0d0
7163 #endif
7164             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7165      &           auxmatd(1,1))
7166             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7167             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7168 c      s1d=0.0d0
7169 c      s2d=0.0d0
7170 c      s8d=0.0d0
7171 c      s12d=0.0d0
7172 c      s13d=0.0d0
7173 #ifdef MOMENT
7174             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7175      &        - 0.5d0*(s1d+s2d)
7176 #else
7177             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7178      &        - 0.5d0*s2d
7179 #endif
7180 #ifdef MOMENT
7181             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7182      &        - 0.5d0*(s8d+s12d)
7183 #else
7184             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7185      &        - 0.5d0*s12d
7186 #endif
7187           enddo
7188         enddo
7189       enddo
7190 #ifdef MOMENT
7191       do kkk=1,5
7192         do lll=1,3
7193           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7194      &      achuj_tempd(1,1))
7195           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7196           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7197           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7198           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7199           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7200      &      vtemp4d(1))
7201           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7202           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7203           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7204         enddo
7205       enddo
7206 #endif
7207 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7208 cd     &  16*eel_turn6_num
7209 cd      goto 1112
7210       if (j.lt.nres-1) then
7211         j1=j+1
7212         j2=j-1
7213       else
7214         j1=j-1
7215         j2=j-2
7216       endif
7217       if (l.lt.nres-1) then
7218         l1=l+1
7219         l2=l-1
7220       else
7221         l1=l-1
7222         l2=l-2
7223       endif
7224       do ll=1,3
7225         ggg1(ll)=eel_turn6*g_contij(ll,1)
7226         ggg2(ll)=eel_turn6*g_contij(ll,2)
7227         ghalf=0.5d0*ggg1(ll)
7228 cd        ghalf=0.0d0
7229         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7230      &    +ekont*derx_turn(ll,2,1)
7231         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7232         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7233      &    +ekont*derx_turn(ll,4,1)
7234         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7235         ghalf=0.5d0*ggg2(ll)
7236 cd        ghalf=0.0d0
7237         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7238      &    +ekont*derx_turn(ll,2,2)
7239         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7240         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7241      &    +ekont*derx_turn(ll,4,2)
7242         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7243       enddo
7244 cd      goto 1112
7245       do m=i+1,j-1
7246         do ll=1,3
7247           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7248         enddo
7249       enddo
7250       do m=k+1,l-1
7251         do ll=1,3
7252           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7253         enddo
7254       enddo
7255 1112  continue
7256       do m=i+2,j2
7257         do ll=1,3
7258           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7259         enddo
7260       enddo
7261       do m=k+2,l2
7262         do ll=1,3
7263           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7264         enddo
7265       enddo
7266 cd      do iii=1,nres-3
7267 cd        write (2,*) iii,g_corr6_loc(iii)
7268 cd      enddo
7269       endif
7270       eello_turn6=ekont*eel_turn6
7271 cd      write (2,*) 'ekont',ekont
7272 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7273       return
7274       end
7275 crc-------------------------------------------------
7276       SUBROUTINE MATVEC2(A1,V1,V2)
7277       implicit real*8 (a-h,o-z)
7278       include 'DIMENSIONS'
7279       DIMENSION A1(2,2),V1(2),V2(2)
7280 c      DO 1 I=1,2
7281 c        VI=0.0
7282 c        DO 3 K=1,2
7283 c    3     VI=VI+A1(I,K)*V1(K)
7284 c        Vaux(I)=VI
7285 c    1 CONTINUE
7286
7287       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7288       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7289
7290       v2(1)=vaux1
7291       v2(2)=vaux2
7292       END
7293 C---------------------------------------
7294       SUBROUTINE MATMAT2(A1,A2,A3)
7295       implicit real*8 (a-h,o-z)
7296       include 'DIMENSIONS'
7297       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7298 c      DIMENSION AI3(2,2)
7299 c        DO  J=1,2
7300 c          A3IJ=0.0
7301 c          DO K=1,2
7302 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7303 c          enddo
7304 c          A3(I,J)=A3IJ
7305 c       enddo
7306 c      enddo
7307
7308       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7309       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7310       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7311       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7312
7313       A3(1,1)=AI3_11
7314       A3(2,1)=AI3_21
7315       A3(1,2)=AI3_12
7316       A3(2,2)=AI3_22
7317       END
7318
7319 c-------------------------------------------------------------------------
7320       double precision function scalar2(u,v)
7321       implicit none
7322       double precision u(2),v(2)
7323       double precision sc
7324       integer i
7325       scalar2=u(1)*v(1)+u(2)*v(2)
7326       return
7327       end
7328
7329 C-----------------------------------------------------------------------------
7330
7331       subroutine transpose2(a,at)
7332       implicit none
7333       double precision a(2,2),at(2,2)
7334       at(1,1)=a(1,1)
7335       at(1,2)=a(2,1)
7336       at(2,1)=a(1,2)
7337       at(2,2)=a(2,2)
7338       return
7339       end
7340 c--------------------------------------------------------------------------
7341       subroutine transpose(n,a,at)
7342       implicit none
7343       integer n,i,j
7344       double precision a(n,n),at(n,n)
7345       do i=1,n
7346         do j=1,n
7347           at(j,i)=a(i,j)
7348         enddo
7349       enddo
7350       return
7351       end
7352 C---------------------------------------------------------------------------
7353       subroutine prodmat3(a1,a2,kk,transp,prod)
7354       implicit none
7355       integer i,j
7356       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
7357       logical transp
7358 crc      double precision auxmat(2,2),prod_(2,2)
7359
7360       if (transp) then
7361 crc        call transpose2(kk(1,1),auxmat(1,1))
7362 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
7363 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7364
7365            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
7366      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
7367            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
7368      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
7369            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
7370      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
7371            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
7372      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
7373
7374       else
7375 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
7376 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7377
7378            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
7379      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
7380            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
7381      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
7382            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
7383      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
7384            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
7385      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
7386
7387       endif
7388 c      call transpose2(a2(1,1),a2t(1,1))
7389
7390 crc      print *,transp
7391 crc      print *,((prod_(i,j),i=1,2),j=1,2)
7392 crc      print *,((prod(i,j),i=1,2),j=1,2)
7393
7394       return
7395       end
7396 C-----------------------------------------------------------------------------
7397       double precision function scalar(u,v)
7398       implicit none
7399       double precision u(3),v(3)
7400       double precision sc
7401       integer i
7402       sc=0.0d0
7403       do i=1,3
7404         sc=sc+u(i)*v(i)
7405       enddo
7406       scalar=sc
7407       return
7408       end
7409