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
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.21) cycle
3353         dethetai=0.0d0
3354         dephii=0.0d0
3355         dephii1=0.0d0
3356         theti2=0.5d0*theta(i)
3357         ityp2=ithetyp(itype(i-1))
3358         do k=1,nntheterm
3359           coskt(k)=dcos(k*theti2)
3360           sinkt(k)=dsin(k*theti2)
3361         enddo
3362         if (i.gt.3 .and. itype(i-2).ne.21) then
3363 #ifdef OSF
3364           phii=phi(i)
3365           if (phii.ne.phii) phii=150.0
3366 #else
3367           phii=phi(i)
3368 #endif
3369           ityp1=ithetyp(itype(i-2))
3370           do k=1,nsingle
3371             cosph1(k)=dcos(k*phii)
3372             sinph1(k)=dsin(k*phii)
3373           enddo
3374         else
3375           phii=0.0d0
3376           ityp1=nthetyp+1
3377           do k=1,nsingle
3378             cosph1(k)=0.0d0
3379             sinph1(k)=0.0d0
3380           enddo
3381         endif
3382         if (i.lt.nres .and. itype(i).ne.21) then
3383 #ifdef OSF
3384           phii1=phi(i+1)
3385           if (phii1.ne.phii1) phii1=150.0
3386           phii1=pinorm(phii1)
3387 #else
3388           phii1=phi(i+1)
3389 #endif
3390           ityp3=ithetyp(itype(i))
3391           do k=1,nsingle
3392             cosph2(k)=dcos(k*phii1)
3393             sinph2(k)=dsin(k*phii1)
3394           enddo
3395         else
3396           phii1=0.0d0
3397           ityp3=nthetyp+1
3398           do k=1,nsingle
3399             cosph2(k)=0.0d0
3400             sinph2(k)=0.0d0
3401           enddo
3402         endif
3403 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
3404 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
3405 c        call flush(iout)
3406         ethetai=aa0thet(ityp1,ityp2,ityp3)
3407         do k=1,ndouble
3408           do l=1,k-1
3409             ccl=cosph1(l)*cosph2(k-l)
3410             ssl=sinph1(l)*sinph2(k-l)
3411             scl=sinph1(l)*cosph2(k-l)
3412             csl=cosph1(l)*sinph2(k-l)
3413             cosph1ph2(l,k)=ccl-ssl
3414             cosph1ph2(k,l)=ccl+ssl
3415             sinph1ph2(l,k)=scl+csl
3416             sinph1ph2(k,l)=scl-csl
3417           enddo
3418         enddo
3419         if (lprn) then
3420         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
3421      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
3422         write (iout,*) "coskt and sinkt"
3423         do k=1,nntheterm
3424           write (iout,*) k,coskt(k),sinkt(k)
3425         enddo
3426         endif
3427         do k=1,ntheterm
3428           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
3429           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
3430      &      *coskt(k)
3431           if (lprn)
3432      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
3433      &     " ethetai",ethetai
3434         enddo
3435         if (lprn) then
3436         write (iout,*) "cosph and sinph"
3437         do k=1,nsingle
3438           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
3439         enddo
3440         write (iout,*) "cosph1ph2 and sinph2ph2"
3441         do k=2,ndouble
3442           do l=1,k-1
3443             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
3444      &         sinph1ph2(l,k),sinph1ph2(k,l)
3445           enddo
3446         enddo
3447         write(iout,*) "ethetai",ethetai
3448         endif
3449         do m=1,ntheterm2
3450           do k=1,nsingle
3451             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
3452      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
3453      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
3454      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
3455             ethetai=ethetai+sinkt(m)*aux
3456             dethetai=dethetai+0.5d0*m*aux*coskt(m)
3457             dephii=dephii+k*sinkt(m)*(
3458      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
3459      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
3460             dephii1=dephii1+k*sinkt(m)*(
3461      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
3462      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
3463             if (lprn)
3464      &      write (iout,*) "m",m," k",k," bbthet",
3465      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
3466      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
3467      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
3468      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3469           enddo
3470         enddo
3471         if (lprn)
3472      &  write(iout,*) "ethetai",ethetai
3473         do m=1,ntheterm3
3474           do k=2,ndouble
3475             do l=1,k-1
3476               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3477      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
3478      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3479      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
3480               ethetai=ethetai+sinkt(m)*aux
3481               dethetai=dethetai+0.5d0*m*coskt(m)*aux
3482               dephii=dephii+l*sinkt(m)*(
3483      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
3484      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3485      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3486      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3487               dephii1=dephii1+(k-l)*sinkt(m)*(
3488      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3489      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3490      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
3491      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3492               if (lprn) then
3493               write (iout,*) "m",m," k",k," l",l," ffthet",
3494      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
3495      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
3496      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
3497      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3498               write (iout,*) cosph1ph2(l,k)*sinkt(m),
3499      &            cosph1ph2(k,l)*sinkt(m),
3500      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
3501               endif
3502             enddo
3503           enddo
3504         enddo
3505 10      continue
3506         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
3507      &   i,theta(i)*rad2deg,phii*rad2deg,
3508      &   phii1*rad2deg,ethetai
3509         etheta=etheta+ethetai
3510         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
3511         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
3512         gloc(nphi+i-2,icg)=wang*dethetai
3513       enddo
3514       return
3515       end
3516 #endif
3517 #ifdef CRYST_SC
3518 c-----------------------------------------------------------------------------
3519       subroutine esc(escloc)
3520 C Calculate the local energy of a side chain and its derivatives in the
3521 C corresponding virtual-bond valence angles THETA and the spherical angles
3522 C ALPHA and OMEGA.
3523       implicit real*8 (a-h,o-z)
3524       include 'DIMENSIONS'
3525       include 'sizesclu.dat'
3526       include 'COMMON.GEO'
3527       include 'COMMON.LOCAL'
3528       include 'COMMON.VAR'
3529       include 'COMMON.INTERACT'
3530       include 'COMMON.DERIV'
3531       include 'COMMON.CHAIN'
3532       include 'COMMON.IOUNITS'
3533       include 'COMMON.NAMES'
3534       include 'COMMON.FFIELD'
3535       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
3536      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
3537       common /sccalc/ time11,time12,time112,theti,it,nlobit
3538       delta=0.02d0*pi
3539       escloc=0.0D0
3540 c     write (iout,'(a)') 'ESC'
3541       do i=loc_start,loc_end
3542         it=itype(i)
3543         if (it.eq.21) cycle
3544         if (it.eq.10) goto 1
3545         nlobit=nlob(it)
3546 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
3547 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
3548         theti=theta(i+1)-pipol
3549         x(1)=dtan(theti)
3550         x(2)=alph(i)
3551         x(3)=omeg(i)
3552 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
3553
3554         if (x(2).gt.pi-delta) then
3555           xtemp(1)=x(1)
3556           xtemp(2)=pi-delta
3557           xtemp(3)=x(3)
3558           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3559           xtemp(2)=pi
3560           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3561           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
3562      &        escloci,dersc(2))
3563           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3564      &        ddersc0(1),dersc(1))
3565           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
3566      &        ddersc0(3),dersc(3))
3567           xtemp(2)=pi-delta
3568           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3569           xtemp(2)=pi
3570           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3571           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
3572      &            dersc0(2),esclocbi,dersc02)
3573           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3574      &            dersc12,dersc01)
3575           call splinthet(x(2),0.5d0*delta,ss,ssd)
3576           dersc0(1)=dersc01
3577           dersc0(2)=dersc02
3578           dersc0(3)=0.0d0
3579           do k=1,3
3580             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3581           enddo
3582           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3583 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3584 c    &             esclocbi,ss,ssd
3585           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3586 c         escloci=esclocbi
3587 c         write (iout,*) escloci
3588         else if (x(2).lt.delta) then
3589           xtemp(1)=x(1)
3590           xtemp(2)=delta
3591           xtemp(3)=x(3)
3592           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3593           xtemp(2)=0.0d0
3594           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3595           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
3596      &        escloci,dersc(2))
3597           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3598      &        ddersc0(1),dersc(1))
3599           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
3600      &        ddersc0(3),dersc(3))
3601           xtemp(2)=delta
3602           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3603           xtemp(2)=0.0d0
3604           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3605           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
3606      &            dersc0(2),esclocbi,dersc02)
3607           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3608      &            dersc12,dersc01)
3609           dersc0(1)=dersc01
3610           dersc0(2)=dersc02
3611           dersc0(3)=0.0d0
3612           call splinthet(x(2),0.5d0*delta,ss,ssd)
3613           do k=1,3
3614             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3615           enddo
3616           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3617 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3618 c    &             esclocbi,ss,ssd
3619           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3620 c         write (iout,*) escloci
3621         else
3622           call enesc(x,escloci,dersc,ddummy,.false.)
3623         endif
3624
3625         escloc=escloc+escloci
3626 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
3627
3628         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3629      &   wscloc*dersc(1)
3630         gloc(ialph(i,1),icg)=wscloc*dersc(2)
3631         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
3632     1   continue
3633       enddo
3634       return
3635       end
3636 C---------------------------------------------------------------------------
3637       subroutine enesc(x,escloci,dersc,ddersc,mixed)
3638       implicit real*8 (a-h,o-z)
3639       include 'DIMENSIONS'
3640       include 'COMMON.GEO'
3641       include 'COMMON.LOCAL'
3642       include 'COMMON.IOUNITS'
3643       common /sccalc/ time11,time12,time112,theti,it,nlobit
3644       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
3645       double precision contr(maxlob,-1:1)
3646       logical mixed
3647 c       write (iout,*) 'it=',it,' nlobit=',nlobit
3648         escloc_i=0.0D0
3649         do j=1,3
3650           dersc(j)=0.0D0
3651           if (mixed) ddersc(j)=0.0d0
3652         enddo
3653         x3=x(3)
3654
3655 C Because of periodicity of the dependence of the SC energy in omega we have
3656 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
3657 C To avoid underflows, first compute & store the exponents.
3658
3659         do iii=-1,1
3660
3661           x(3)=x3+iii*dwapi
3662
3663           do j=1,nlobit
3664             do k=1,3
3665               z(k)=x(k)-censc(k,j,it)
3666             enddo
3667             do k=1,3
3668               Axk=0.0D0
3669               do l=1,3
3670                 Axk=Axk+gaussc(l,k,j,it)*z(l)
3671               enddo
3672               Ax(k,j,iii)=Axk
3673             enddo
3674             expfac=0.0D0
3675             do k=1,3
3676               expfac=expfac+Ax(k,j,iii)*z(k)
3677             enddo
3678             contr(j,iii)=expfac
3679           enddo ! j
3680
3681         enddo ! iii
3682
3683         x(3)=x3
3684 C As in the case of ebend, we want to avoid underflows in exponentiation and
3685 C subsequent NaNs and INFs in energy calculation.
3686 C Find the largest exponent
3687         emin=contr(1,-1)
3688         do iii=-1,1
3689           do j=1,nlobit
3690             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
3691           enddo
3692         enddo
3693         emin=0.5D0*emin
3694 cd      print *,'it=',it,' emin=',emin
3695
3696 C Compute the contribution to SC energy and derivatives
3697         do iii=-1,1
3698
3699           do j=1,nlobit
3700             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
3701 cd          print *,'j=',j,' expfac=',expfac
3702             escloc_i=escloc_i+expfac
3703             do k=1,3
3704               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
3705             enddo
3706             if (mixed) then
3707               do k=1,3,2
3708                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
3709      &            +gaussc(k,2,j,it))*expfac
3710               enddo
3711             endif
3712           enddo
3713
3714         enddo ! iii
3715
3716         dersc(1)=dersc(1)/cos(theti)**2
3717         ddersc(1)=ddersc(1)/cos(theti)**2
3718         ddersc(3)=ddersc(3)
3719
3720         escloci=-(dlog(escloc_i)-emin)
3721         do j=1,3
3722           dersc(j)=dersc(j)/escloc_i
3723         enddo
3724         if (mixed) then
3725           do j=1,3,2
3726             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
3727           enddo
3728         endif
3729       return
3730       end
3731 C------------------------------------------------------------------------------
3732       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
3733       implicit real*8 (a-h,o-z)
3734       include 'DIMENSIONS'
3735       include 'COMMON.GEO'
3736       include 'COMMON.LOCAL'
3737       include 'COMMON.IOUNITS'
3738       common /sccalc/ time11,time12,time112,theti,it,nlobit
3739       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
3740       double precision contr(maxlob)
3741       logical mixed
3742
3743       escloc_i=0.0D0
3744
3745       do j=1,3
3746         dersc(j)=0.0D0
3747       enddo
3748
3749       do j=1,nlobit
3750         do k=1,2
3751           z(k)=x(k)-censc(k,j,it)
3752         enddo
3753         z(3)=dwapi
3754         do k=1,3
3755           Axk=0.0D0
3756           do l=1,3
3757             Axk=Axk+gaussc(l,k,j,it)*z(l)
3758           enddo
3759           Ax(k,j)=Axk
3760         enddo
3761         expfac=0.0D0
3762         do k=1,3
3763           expfac=expfac+Ax(k,j)*z(k)
3764         enddo
3765         contr(j)=expfac
3766       enddo ! j
3767
3768 C As in the case of ebend, we want to avoid underflows in exponentiation and
3769 C subsequent NaNs and INFs in energy calculation.
3770 C Find the largest exponent
3771       emin=contr(1)
3772       do j=1,nlobit
3773         if (emin.gt.contr(j)) emin=contr(j)
3774       enddo
3775       emin=0.5D0*emin
3776
3777 C Compute the contribution to SC energy and derivatives
3778
3779       dersc12=0.0d0
3780       do j=1,nlobit
3781         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
3782         escloc_i=escloc_i+expfac
3783         do k=1,2
3784           dersc(k)=dersc(k)+Ax(k,j)*expfac
3785         enddo
3786         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
3787      &            +gaussc(1,2,j,it))*expfac
3788         dersc(3)=0.0d0
3789       enddo
3790
3791       dersc(1)=dersc(1)/cos(theti)**2
3792       dersc12=dersc12/cos(theti)**2
3793       escloci=-(dlog(escloc_i)-emin)
3794       do j=1,2
3795         dersc(j)=dersc(j)/escloc_i
3796       enddo
3797       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
3798       return
3799       end
3800 #else
3801 c----------------------------------------------------------------------------------
3802       subroutine esc(escloc)
3803 C Calculate the local energy of a side chain and its derivatives in the
3804 C corresponding virtual-bond valence angles THETA and the spherical angles
3805 C ALPHA and OMEGA derived from AM1 all-atom calculations.
3806 C added by Urszula Kozlowska. 07/11/2007
3807 C
3808       implicit real*8 (a-h,o-z)
3809       include 'DIMENSIONS'
3810       include 'sizesclu.dat'
3811       include 'COMMON.GEO'
3812       include 'COMMON.LOCAL'
3813       include 'COMMON.VAR'
3814       include 'COMMON.SCROT'
3815       include 'COMMON.INTERACT'
3816       include 'COMMON.DERIV'
3817       include 'COMMON.CHAIN'
3818       include 'COMMON.IOUNITS'
3819       include 'COMMON.NAMES'
3820       include 'COMMON.FFIELD'
3821       include 'COMMON.CONTROL'
3822       include 'COMMON.VECTORS'
3823       double precision x_prime(3),y_prime(3),z_prime(3)
3824      &    , sumene,dsc_i,dp2_i,x(65),
3825      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
3826      &    de_dxx,de_dyy,de_dzz,de_dt
3827       double precision s1_t,s1_6_t,s2_t,s2_6_t
3828       double precision
3829      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
3830      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
3831      & dt_dCi(3),dt_dCi1(3)
3832       common /sccalc/ time11,time12,time112,theti,it,nlobit
3833       delta=0.02d0*pi
3834       escloc=0.0D0
3835       do i=loc_start,loc_end
3836         if (itype(i).eq.21) cycle
3837         costtab(i+1) =dcos(theta(i+1))
3838         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
3839         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
3840         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
3841         cosfac2=0.5d0/(1.0d0+costtab(i+1))
3842         cosfac=dsqrt(cosfac2)
3843         sinfac2=0.5d0/(1.0d0-costtab(i+1))
3844         sinfac=dsqrt(sinfac2)
3845         it=itype(i)
3846         if (it.eq.10) goto 1
3847 c
3848 C  Compute the axes of tghe local cartesian coordinates system; store in
3849 c   x_prime, y_prime and z_prime
3850 c
3851         do j=1,3
3852           x_prime(j) = 0.00
3853           y_prime(j) = 0.00
3854           z_prime(j) = 0.00
3855         enddo
3856 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
3857 C     &   dc_norm(3,i+nres)
3858         do j = 1,3
3859           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
3860           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
3861         enddo
3862         do j = 1,3
3863           z_prime(j) = -uz(j,i-1)
3864         enddo
3865 c       write (2,*) "i",i
3866 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
3867 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
3868 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
3869 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
3870 c      & " xy",scalar(x_prime(1),y_prime(1)),
3871 c      & " xz",scalar(x_prime(1),z_prime(1)),
3872 c      & " yy",scalar(y_prime(1),y_prime(1)),
3873 c      & " yz",scalar(y_prime(1),z_prime(1)),
3874 c      & " zz",scalar(z_prime(1),z_prime(1))
3875 c
3876 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
3877 C to local coordinate system. Store in xx, yy, zz.
3878 c
3879         xx=0.0d0
3880         yy=0.0d0
3881         zz=0.0d0
3882         do j = 1,3
3883           xx = xx + x_prime(j)*dc_norm(j,i+nres)
3884           yy = yy + y_prime(j)*dc_norm(j,i+nres)
3885           zz = zz + z_prime(j)*dc_norm(j,i+nres)
3886         enddo
3887
3888         xxtab(i)=xx
3889         yytab(i)=yy
3890         zztab(i)=zz
3891 C
3892 C Compute the energy of the ith side cbain
3893 C
3894 c        write (2,*) "xx",xx," yy",yy," zz",zz
3895         it=itype(i)
3896         do j = 1,65
3897           x(j) = sc_parmin(j,it)
3898         enddo
3899 #ifdef CHECK_COORD
3900 Cc diagnostics - remove later
3901         xx1 = dcos(alph(2))
3902         yy1 = dsin(alph(2))*dcos(omeg(2))
3903         zz1 = -dsin(alph(2))*dsin(omeg(2))
3904         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
3905      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
3906      &    xx1,yy1,zz1
3907 C,"  --- ", xx_w,yy_w,zz_w
3908 c end diagnostics
3909 #endif
3910         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
3911      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
3912      &   + x(10)*yy*zz
3913         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
3914      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
3915      & + x(20)*yy*zz
3916         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
3917      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
3918      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
3919      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
3920      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
3921      &  +x(40)*xx*yy*zz
3922         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
3923      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
3924      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
3925      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
3926      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
3927      &  +x(60)*xx*yy*zz
3928         dsc_i   = 0.743d0+x(61)
3929         dp2_i   = 1.9d0+x(62)
3930         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
3931      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
3932         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
3933      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
3934         s1=(1+x(63))/(0.1d0 + dscp1)
3935         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
3936         s2=(1+x(65))/(0.1d0 + dscp2)
3937         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
3938         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
3939      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
3940 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
3941 c     &   sumene4,
3942 c     &   dscp1,dscp2,sumene
3943 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
3944         escloc = escloc + sumene
3945 c        write (2,*) "escloc",escloc
3946         if (.not. calc_grad) goto 1
3947 #ifdef DEBUG
3948 C
3949 C This section to check the numerical derivatives of the energy of ith side
3950 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
3951 C #define DEBUG in the code to turn it on.
3952 C
3953         write (2,*) "sumene               =",sumene
3954         aincr=1.0d-7
3955         xxsave=xx
3956         xx=xx+aincr
3957         write (2,*) xx,yy,zz
3958         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
3959         de_dxx_num=(sumenep-sumene)/aincr
3960         xx=xxsave
3961         write (2,*) "xx+ sumene from enesc=",sumenep
3962         yysave=yy
3963         yy=yy+aincr
3964         write (2,*) xx,yy,zz
3965         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
3966         de_dyy_num=(sumenep-sumene)/aincr
3967         yy=yysave
3968         write (2,*) "yy+ sumene from enesc=",sumenep
3969         zzsave=zz
3970         zz=zz+aincr
3971         write (2,*) xx,yy,zz
3972         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
3973         de_dzz_num=(sumenep-sumene)/aincr
3974         zz=zzsave
3975         write (2,*) "zz+ sumene from enesc=",sumenep
3976         costsave=cost2tab(i+1)
3977         sintsave=sint2tab(i+1)
3978         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
3979         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
3980         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
3981         de_dt_num=(sumenep-sumene)/aincr
3982         write (2,*) " t+ sumene from enesc=",sumenep
3983         cost2tab(i+1)=costsave
3984         sint2tab(i+1)=sintsave
3985 C End of diagnostics section.
3986 #endif
3987 C
3988 C Compute the gradient of esc
3989 C
3990         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
3991         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
3992         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
3993         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
3994         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
3995         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
3996         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
3997         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
3998         pom1=(sumene3*sint2tab(i+1)+sumene1)
3999      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4000         pom2=(sumene4*cost2tab(i+1)+sumene2)
4001      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4002         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4003         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4004      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4005      &  +x(40)*yy*zz
4006         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4007         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4008      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4009      &  +x(60)*yy*zz
4010         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4011      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4012      &        +(pom1+pom2)*pom_dx
4013 #ifdef DEBUG
4014         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4015 #endif
4016 C
4017         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4018         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4019      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4020      &  +x(40)*xx*zz
4021         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4022         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4023      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4024      &  +x(59)*zz**2 +x(60)*xx*zz
4025         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4026      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4027      &        +(pom1-pom2)*pom_dy
4028 #ifdef DEBUG
4029         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4030 #endif
4031 C
4032         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4033      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4034      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4035      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4036      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4037      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4038      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4039      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4040 #ifdef DEBUG
4041         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4042 #endif
4043 C
4044         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4045      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4046      &  +pom1*pom_dt1+pom2*pom_dt2
4047 #ifdef DEBUG
4048         write(2,*), "de_dt = ", de_dt,de_dt_num
4049 #endif
4050 c
4051 C
4052        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4053        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4054        cosfac2xx=cosfac2*xx
4055        sinfac2yy=sinfac2*yy
4056        do k = 1,3
4057          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4058      &      vbld_inv(i+1)
4059          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4060      &      vbld_inv(i)
4061          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4062          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4063 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4064 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4065 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4066 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4067          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4068          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4069          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4070          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4071          dZZ_Ci1(k)=0.0d0
4072          dZZ_Ci(k)=0.0d0
4073          do j=1,3
4074            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4075            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4076          enddo
4077
4078          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4079          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4080          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4081 c
4082          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4083          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4084        enddo
4085
4086        do k=1,3
4087          dXX_Ctab(k,i)=dXX_Ci(k)
4088          dXX_C1tab(k,i)=dXX_Ci1(k)
4089          dYY_Ctab(k,i)=dYY_Ci(k)
4090          dYY_C1tab(k,i)=dYY_Ci1(k)
4091          dZZ_Ctab(k,i)=dZZ_Ci(k)
4092          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4093          dXX_XYZtab(k,i)=dXX_XYZ(k)
4094          dYY_XYZtab(k,i)=dYY_XYZ(k)
4095          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4096        enddo
4097
4098        do k = 1,3
4099 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4100 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4101 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4102 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4103 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4104 c     &    dt_dci(k)
4105 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4106 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4107          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4108      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4109          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4110      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4111          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4112      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4113        enddo
4114 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4115 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4116
4117 C to check gradient call subroutine check_grad
4118
4119     1 continue
4120       enddo
4121       return
4122       end
4123 #endif
4124 c------------------------------------------------------------------------------
4125       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4126 C
4127 C This procedure calculates two-body contact function g(rij) and its derivative:
4128 C
4129 C           eps0ij                                     !       x < -1
4130 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4131 C            0                                         !       x > 1
4132 C
4133 C where x=(rij-r0ij)/delta
4134 C
4135 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4136 C
4137       implicit none
4138       double precision rij,r0ij,eps0ij,fcont,fprimcont
4139       double precision x,x2,x4,delta
4140 c     delta=0.02D0*r0ij
4141 c      delta=0.2D0*r0ij
4142       x=(rij-r0ij)/delta
4143       if (x.lt.-1.0D0) then
4144         fcont=eps0ij
4145         fprimcont=0.0D0
4146       else if (x.le.1.0D0) then
4147         x2=x*x
4148         x4=x2*x2
4149         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4150         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4151       else
4152         fcont=0.0D0
4153         fprimcont=0.0D0
4154       endif
4155       return
4156       end
4157 c------------------------------------------------------------------------------
4158       subroutine splinthet(theti,delta,ss,ssder)
4159       implicit real*8 (a-h,o-z)
4160       include 'DIMENSIONS'
4161       include 'sizesclu.dat'
4162       include 'COMMON.VAR'
4163       include 'COMMON.GEO'
4164       thetup=pi-delta
4165       thetlow=delta
4166       if (theti.gt.pipol) then
4167         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4168       else
4169         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4170         ssder=-ssder
4171       endif
4172       return
4173       end
4174 c------------------------------------------------------------------------------
4175       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4176       implicit none
4177       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4178       double precision ksi,ksi2,ksi3,a1,a2,a3
4179       a1=fprim0*delta/(f1-f0)
4180       a2=3.0d0-2.0d0*a1
4181       a3=a1-2.0d0
4182       ksi=(x-x0)/delta
4183       ksi2=ksi*ksi
4184       ksi3=ksi2*ksi
4185       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4186       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4187       return
4188       end
4189 c------------------------------------------------------------------------------
4190       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4191       implicit none
4192       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4193       double precision ksi,ksi2,ksi3,a1,a2,a3
4194       ksi=(x-x0)/delta
4195       ksi2=ksi*ksi
4196       ksi3=ksi2*ksi
4197       a1=fprim0x*delta
4198       a2=3*(f1x-f0x)-2*fprim0x*delta
4199       a3=fprim0x*delta-2*(f1x-f0x)
4200       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4201       return
4202       end
4203 C-----------------------------------------------------------------------------
4204 #ifdef CRYST_TOR
4205 C-----------------------------------------------------------------------------
4206       subroutine etor(etors,edihcnstr,fact)
4207       implicit real*8 (a-h,o-z)
4208       include 'DIMENSIONS'
4209       include 'sizesclu.dat'
4210       include 'COMMON.VAR'
4211       include 'COMMON.GEO'
4212       include 'COMMON.LOCAL'
4213       include 'COMMON.TORSION'
4214       include 'COMMON.INTERACT'
4215       include 'COMMON.DERIV'
4216       include 'COMMON.CHAIN'
4217       include 'COMMON.NAMES'
4218       include 'COMMON.IOUNITS'
4219       include 'COMMON.FFIELD'
4220       include 'COMMON.TORCNSTR'
4221       logical lprn
4222 C Set lprn=.true. for debugging
4223       lprn=.false.
4224 c      lprn=.true.
4225       etors=0.0D0
4226       do i=iphi_start,iphi_end
4227         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
4228      &      .or. itype(i).eq.21) cycle
4229         itori=itortyp(itype(i-2))
4230         itori1=itortyp(itype(i-1))
4231         phii=phi(i)
4232         gloci=0.0D0
4233 C Proline-Proline pair is a special case...
4234         if (itori.eq.3 .and. itori1.eq.3) then
4235           if (phii.gt.-dwapi3) then
4236             cosphi=dcos(3*phii)
4237             fac=1.0D0/(1.0D0-cosphi)
4238             etorsi=v1(1,3,3)*fac
4239             etorsi=etorsi+etorsi
4240             etors=etors+etorsi-v1(1,3,3)
4241             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4242           endif
4243           do j=1,3
4244             v1ij=v1(j+1,itori,itori1)
4245             v2ij=v2(j+1,itori,itori1)
4246             cosphi=dcos(j*phii)
4247             sinphi=dsin(j*phii)
4248             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4249             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4250           enddo
4251         else
4252           do j=1,nterm_old
4253             v1ij=v1(j,itori,itori1)
4254             v2ij=v2(j,itori,itori1)
4255             cosphi=dcos(j*phii)
4256             sinphi=dsin(j*phii)
4257             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4258             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4259           enddo
4260         endif
4261         if (lprn)
4262      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4263      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4264      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4265         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4266 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4267       enddo
4268 ! 6/20/98 - dihedral angle constraints
4269       edihcnstr=0.0d0
4270       do i=1,ndih_constr
4271         itori=idih_constr(i)
4272         phii=phi(itori)
4273         difi=phii-phi0(i)
4274         if (difi.gt.drange(i)) then
4275           difi=difi-drange(i)
4276           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4277           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4278         else if (difi.lt.-drange(i)) then
4279           difi=difi+drange(i)
4280           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4281           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4282         endif
4283 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4284 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4285       enddo
4286 !      write (iout,*) 'edihcnstr',edihcnstr
4287       return
4288       end
4289 c------------------------------------------------------------------------------
4290 #else
4291       subroutine etor(etors,edihcnstr,fact)
4292       implicit real*8 (a-h,o-z)
4293       include 'DIMENSIONS'
4294       include 'sizesclu.dat'
4295       include 'COMMON.VAR'
4296       include 'COMMON.GEO'
4297       include 'COMMON.LOCAL'
4298       include 'COMMON.TORSION'
4299       include 'COMMON.INTERACT'
4300       include 'COMMON.DERIV'
4301       include 'COMMON.CHAIN'
4302       include 'COMMON.NAMES'
4303       include 'COMMON.IOUNITS'
4304       include 'COMMON.FFIELD'
4305       include 'COMMON.TORCNSTR'
4306       logical lprn
4307 C Set lprn=.true. for debugging
4308       lprn=.false.
4309 c      lprn=.true.
4310       etors=0.0D0
4311       do i=iphi_start,iphi_end
4312         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
4313      &       .or. itype(i).eq.21) cycle
4314         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4315         itori=itortyp(itype(i-2))
4316         itori1=itortyp(itype(i-1))
4317         phii=phi(i)
4318         gloci=0.0D0
4319 C Regular cosine and sine terms
4320         do j=1,nterm(itori,itori1)
4321           v1ij=v1(j,itori,itori1)
4322           v2ij=v2(j,itori,itori1)
4323           cosphi=dcos(j*phii)
4324           sinphi=dsin(j*phii)
4325           etors=etors+v1ij*cosphi+v2ij*sinphi
4326           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4327         enddo
4328 C Lorentz terms
4329 C                         v1
4330 C  E = SUM ----------------------------------- - v1
4331 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4332 C
4333         cosphi=dcos(0.5d0*phii)
4334         sinphi=dsin(0.5d0*phii)
4335         do j=1,nlor(itori,itori1)
4336           vl1ij=vlor1(j,itori,itori1)
4337           vl2ij=vlor2(j,itori,itori1)
4338           vl3ij=vlor3(j,itori,itori1)
4339           pom=vl2ij*cosphi+vl3ij*sinphi
4340           pom1=1.0d0/(pom*pom+1.0d0)
4341           etors=etors+vl1ij*pom1
4342           pom=-pom*pom1*pom1
4343           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4344         enddo
4345 C Subtract the constant term
4346         etors=etors-v0(itori,itori1)
4347         if (lprn)
4348      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4349      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4350      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4351         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4352 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4353  1215   continue
4354       enddo
4355 ! 6/20/98 - dihedral angle constraints
4356       edihcnstr=0.0d0
4357       do i=1,ndih_constr
4358         itori=idih_constr(i)
4359         phii=phi(itori)
4360         difi=pinorm(phii-phi0(i))
4361         edihi=0.0d0
4362         if (difi.gt.drange(i)) then
4363           difi=difi-drange(i)
4364           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4365           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4366           edihi=0.25d0*ftors*difi**4
4367         else if (difi.lt.-drange(i)) then
4368           difi=difi+drange(i)
4369           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4370           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4371           edihi=0.25d0*ftors*difi**4
4372         else
4373           difi=0.0d0
4374         endif
4375 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
4376 c     &    drange(i),edihi
4377 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4378 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4379       enddo
4380 !      write (iout,*) 'edihcnstr',edihcnstr
4381       return
4382       end
4383 c----------------------------------------------------------------------------
4384       subroutine etor_d(etors_d,fact2)
4385 C 6/23/01 Compute double torsional energy
4386       implicit real*8 (a-h,o-z)
4387       include 'DIMENSIONS'
4388       include 'sizesclu.dat'
4389       include 'COMMON.VAR'
4390       include 'COMMON.GEO'
4391       include 'COMMON.LOCAL'
4392       include 'COMMON.TORSION'
4393       include 'COMMON.INTERACT'
4394       include 'COMMON.DERIV'
4395       include 'COMMON.CHAIN'
4396       include 'COMMON.NAMES'
4397       include 'COMMON.IOUNITS'
4398       include 'COMMON.FFIELD'
4399       include 'COMMON.TORCNSTR'
4400       logical lprn
4401 C Set lprn=.true. for debugging
4402       lprn=.false.
4403 c     lprn=.true.
4404       etors_d=0.0D0
4405       do i=iphi_start,iphi_end-1
4406         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
4407      &      .or. itype(i).eq.21 .or. itype(i+1).eq.21) cycle
4408         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
4409      &     goto 1215
4410         itori=itortyp(itype(i-2))
4411         itori1=itortyp(itype(i-1))
4412         itori2=itortyp(itype(i))
4413         phii=phi(i)
4414         phii1=phi(i+1)
4415         gloci1=0.0D0
4416         gloci2=0.0D0
4417 C Regular cosine and sine terms
4418         do j=1,ntermd_1(itori,itori1,itori2)
4419           v1cij=v1c(1,j,itori,itori1,itori2)
4420           v1sij=v1s(1,j,itori,itori1,itori2)
4421           v2cij=v1c(2,j,itori,itori1,itori2)
4422           v2sij=v1s(2,j,itori,itori1,itori2)
4423           cosphi1=dcos(j*phii)
4424           sinphi1=dsin(j*phii)
4425           cosphi2=dcos(j*phii1)
4426           sinphi2=dsin(j*phii1)
4427           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
4428      &     v2cij*cosphi2+v2sij*sinphi2
4429           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
4430           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
4431         enddo
4432         do k=2,ntermd_2(itori,itori1,itori2)
4433           do l=1,k-1
4434             v1cdij = v2c(k,l,itori,itori1,itori2)
4435             v2cdij = v2c(l,k,itori,itori1,itori2)
4436             v1sdij = v2s(k,l,itori,itori1,itori2)
4437             v2sdij = v2s(l,k,itori,itori1,itori2)
4438             cosphi1p2=dcos(l*phii+(k-l)*phii1)
4439             cosphi1m2=dcos(l*phii-(k-l)*phii1)
4440             sinphi1p2=dsin(l*phii+(k-l)*phii1)
4441             sinphi1m2=dsin(l*phii-(k-l)*phii1)
4442             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
4443      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
4444             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
4445      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
4446             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
4447      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
4448           enddo
4449         enddo
4450         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
4451         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
4452  1215   continue
4453       enddo
4454       return
4455       end
4456 #endif
4457 c------------------------------------------------------------------------------
4458       subroutine eback_sc_corr(esccor)
4459 c 7/21/2007 Correlations between the backbone-local and side-chain-local
4460 c        conformational states; temporarily implemented as differences
4461 c        between UNRES torsional potentials (dependent on three types of
4462 c        residues) and the torsional potentials dependent on all 20 types
4463 c        of residues computed from AM1 energy surfaces of terminally-blocked
4464 c        amino-acid residues.
4465       implicit real*8 (a-h,o-z)
4466       include 'DIMENSIONS'
4467       include 'sizesclu.dat'
4468       include 'COMMON.VAR'
4469       include 'COMMON.GEO'
4470       include 'COMMON.LOCAL'
4471       include 'COMMON.TORSION'
4472       include 'COMMON.SCCOR'
4473       include 'COMMON.INTERACT'
4474       include 'COMMON.DERIV'
4475       include 'COMMON.CHAIN'
4476       include 'COMMON.NAMES'
4477       include 'COMMON.IOUNITS'
4478       include 'COMMON.FFIELD'
4479       include 'COMMON.CONTROL'
4480       logical lprn
4481 C Set lprn=.true. for debugging
4482       lprn=.false.
4483 c      lprn=.true.
4484 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
4485       esccor=0.0D0
4486       do i=iphi_start,iphi_end
4487         if (itype(i-2).eq.21 .or. itype(i-1).eq.21) cycle
4488         esccor_ii=0.0D0
4489         itori=itype(i-2)
4490         itori1=itype(i-1)
4491         phii=phi(i)
4492         gloci=0.0D0
4493         do j=1,nterm_sccor
4494           v1ij=v1sccor(j,itori,itori1)
4495           v2ij=v2sccor(j,itori,itori1)
4496           cosphi=dcos(j*phii)
4497           sinphi=dsin(j*phii)
4498           esccor=esccor+v1ij*cosphi+v2ij*sinphi
4499           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4500         enddo
4501         if (lprn)
4502      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4503      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4504      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
4505         gsccor_loc(i-3)=gloci
4506       enddo
4507       return
4508       end
4509 c------------------------------------------------------------------------------
4510       subroutine multibody(ecorr)
4511 C This subroutine calculates multi-body contributions to energy following
4512 C the idea of Skolnick et al. If side chains I and J make a contact and
4513 C at the same time side chains I+1 and J+1 make a contact, an extra
4514 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
4515       implicit real*8 (a-h,o-z)
4516       include 'DIMENSIONS'
4517       include 'COMMON.IOUNITS'
4518       include 'COMMON.DERIV'
4519       include 'COMMON.INTERACT'
4520       include 'COMMON.CONTACTS'
4521       double precision gx(3),gx1(3)
4522       logical lprn
4523
4524 C Set lprn=.true. for debugging
4525       lprn=.false.
4526
4527       if (lprn) then
4528         write (iout,'(a)') 'Contact function values:'
4529         do i=nnt,nct-2
4530           write (iout,'(i2,20(1x,i2,f10.5))')
4531      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
4532         enddo
4533       endif
4534       ecorr=0.0D0
4535       do i=nnt,nct
4536         do j=1,3
4537           gradcorr(j,i)=0.0D0
4538           gradxorr(j,i)=0.0D0
4539         enddo
4540       enddo
4541       do i=nnt,nct-2
4542
4543         DO ISHIFT = 3,4
4544
4545         i1=i+ishift
4546         num_conti=num_cont(i)
4547         num_conti1=num_cont(i1)
4548         do jj=1,num_conti
4549           j=jcont(jj,i)
4550           do kk=1,num_conti1
4551             j1=jcont(kk,i1)
4552             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
4553 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4554 cd   &                   ' ishift=',ishift
4555 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
4556 C The system gains extra energy.
4557               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
4558             endif   ! j1==j+-ishift
4559           enddo     ! kk
4560         enddo       ! jj
4561
4562         ENDDO ! ISHIFT
4563
4564       enddo         ! i
4565       return
4566       end
4567 c------------------------------------------------------------------------------
4568       double precision function esccorr(i,j,k,l,jj,kk)
4569       implicit real*8 (a-h,o-z)
4570       include 'DIMENSIONS'
4571       include 'COMMON.IOUNITS'
4572       include 'COMMON.DERIV'
4573       include 'COMMON.INTERACT'
4574       include 'COMMON.CONTACTS'
4575       double precision gx(3),gx1(3)
4576       logical lprn
4577       lprn=.false.
4578       eij=facont(jj,i)
4579       ekl=facont(kk,k)
4580 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
4581 C Calculate the multi-body contribution to energy.
4582 C Calculate multi-body contributions to the gradient.
4583 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
4584 cd   & k,l,(gacont(m,kk,k),m=1,3)
4585       do m=1,3
4586         gx(m) =ekl*gacont(m,jj,i)
4587         gx1(m)=eij*gacont(m,kk,k)
4588         gradxorr(m,i)=gradxorr(m,i)-gx(m)
4589         gradxorr(m,j)=gradxorr(m,j)+gx(m)
4590         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
4591         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
4592       enddo
4593       do m=i,j-1
4594         do ll=1,3
4595           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
4596         enddo
4597       enddo
4598       do m=k,l-1
4599         do ll=1,3
4600           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
4601         enddo
4602       enddo
4603       esccorr=-eij*ekl
4604       return
4605       end
4606 c------------------------------------------------------------------------------
4607 #ifdef MPL
4608       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
4609       implicit real*8 (a-h,o-z)
4610       include 'DIMENSIONS'
4611       integer dimen1,dimen2,atom,indx
4612       double precision buffer(dimen1,dimen2)
4613       double precision zapas
4614       common /contacts_hb/ zapas(3,20,maxres,7),
4615      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4616      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4617       num_kont=num_cont_hb(atom)
4618       do i=1,num_kont
4619         do k=1,7
4620           do j=1,3
4621             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
4622           enddo ! j
4623         enddo ! k
4624         buffer(i,indx+22)=facont_hb(i,atom)
4625         buffer(i,indx+23)=ees0p(i,atom)
4626         buffer(i,indx+24)=ees0m(i,atom)
4627         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
4628       enddo ! i
4629       buffer(1,indx+26)=dfloat(num_kont)
4630       return
4631       end
4632 c------------------------------------------------------------------------------
4633       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
4634       implicit real*8 (a-h,o-z)
4635       include 'DIMENSIONS'
4636       integer dimen1,dimen2,atom,indx
4637       double precision buffer(dimen1,dimen2)
4638       double precision zapas
4639       common /contacts_hb/ zapas(3,20,maxres,7),
4640      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4641      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4642       num_kont=buffer(1,indx+26)
4643       num_kont_old=num_cont_hb(atom)
4644       num_cont_hb(atom)=num_kont+num_kont_old
4645       do i=1,num_kont
4646         ii=i+num_kont_old
4647         do k=1,7
4648           do j=1,3
4649             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
4650           enddo ! j
4651         enddo ! k
4652         facont_hb(ii,atom)=buffer(i,indx+22)
4653         ees0p(ii,atom)=buffer(i,indx+23)
4654         ees0m(ii,atom)=buffer(i,indx+24)
4655         jcont_hb(ii,atom)=buffer(i,indx+25)
4656       enddo ! i
4657       return
4658       end
4659 c------------------------------------------------------------------------------
4660 #endif
4661       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
4662 C This subroutine calculates multi-body contributions to hydrogen-bonding
4663       implicit real*8 (a-h,o-z)
4664       include 'DIMENSIONS'
4665       include 'sizesclu.dat'
4666       include 'COMMON.IOUNITS'
4667 #ifdef MPL
4668       include 'COMMON.INFO'
4669 #endif
4670       include 'COMMON.FFIELD'
4671       include 'COMMON.DERIV'
4672       include 'COMMON.INTERACT'
4673       include 'COMMON.CONTACTS'
4674 #ifdef MPL
4675       parameter (max_cont=maxconts)
4676       parameter (max_dim=2*(8*3+2))
4677       parameter (msglen1=max_cont*max_dim*4)
4678       parameter (msglen2=2*msglen1)
4679       integer source,CorrelType,CorrelID,Error
4680       double precision buffer(max_cont,max_dim)
4681 #endif
4682       double precision gx(3),gx1(3)
4683       logical lprn,ldone
4684
4685 C Set lprn=.true. for debugging
4686       lprn=.false.
4687 #ifdef MPL
4688       n_corr=0
4689       n_corr1=0
4690       if (fgProcs.le.1) goto 30
4691       if (lprn) then
4692         write (iout,'(a)') 'Contact function values:'
4693         do i=nnt,nct-2
4694           write (iout,'(2i3,50(1x,i2,f5.2))')
4695      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4696      &    j=1,num_cont_hb(i))
4697         enddo
4698       endif
4699 C Caution! Following code assumes that electrostatic interactions concerning
4700 C a given atom are split among at most two processors!
4701       CorrelType=477
4702       CorrelID=MyID+1
4703       ldone=.false.
4704       do i=1,max_cont
4705         do j=1,max_dim
4706           buffer(i,j)=0.0D0
4707         enddo
4708       enddo
4709       mm=mod(MyRank,2)
4710 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
4711       if (mm) 20,20,10
4712    10 continue
4713 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
4714       if (MyRank.gt.0) then
4715 C Send correlation contributions to the preceding processor
4716         msglen=msglen1
4717         nn=num_cont_hb(iatel_s)
4718         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
4719 cd      write (iout,*) 'The BUFFER array:'
4720 cd      do i=1,nn
4721 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
4722 cd      enddo
4723         if (ielstart(iatel_s).gt.iatel_s+ispp) then
4724           msglen=msglen2
4725             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
4726 C Clear the contacts of the atom passed to the neighboring processor
4727         nn=num_cont_hb(iatel_s+1)
4728 cd      do i=1,nn
4729 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
4730 cd      enddo
4731             num_cont_hb(iatel_s)=0
4732         endif
4733 cd      write (iout,*) 'Processor ',MyID,MyRank,
4734 cd   & ' is sending correlation contribution to processor',MyID-1,
4735 cd   & ' msglen=',msglen
4736 cd      write (*,*) 'Processor ',MyID,MyRank,
4737 cd   & ' is sending correlation contribution to processor',MyID-1,
4738 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4739         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
4740 cd      write (iout,*) 'Processor ',MyID,
4741 cd   & ' has sent correlation contribution to processor',MyID-1,
4742 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4743 cd      write (*,*) 'Processor ',MyID,
4744 cd   & ' has sent correlation contribution to processor',MyID-1,
4745 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4746         msglen=msglen1
4747       endif ! (MyRank.gt.0)
4748       if (ldone) goto 30
4749       ldone=.true.
4750    20 continue
4751 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
4752       if (MyRank.lt.fgProcs-1) then
4753 C Receive correlation contributions from the next processor
4754         msglen=msglen1
4755         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
4756 cd      write (iout,*) 'Processor',MyID,
4757 cd   & ' is receiving correlation contribution from processor',MyID+1,
4758 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4759 cd      write (*,*) 'Processor',MyID,
4760 cd   & ' is receiving correlation contribution from processor',MyID+1,
4761 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4762         nbytes=-1
4763         do while (nbytes.le.0)
4764           call mp_probe(MyID+1,CorrelType,nbytes)
4765         enddo
4766 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
4767         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
4768 cd      write (iout,*) 'Processor',MyID,
4769 cd   & ' has received correlation contribution from processor',MyID+1,
4770 cd   & ' msglen=',msglen,' nbytes=',nbytes
4771 cd      write (iout,*) 'The received BUFFER array:'
4772 cd      do i=1,max_cont
4773 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
4774 cd      enddo
4775         if (msglen.eq.msglen1) then
4776           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
4777         else if (msglen.eq.msglen2)  then
4778           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
4779           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
4780         else
4781           write (iout,*)
4782      & 'ERROR!!!! message length changed while processing correlations.'
4783           write (*,*)
4784      & 'ERROR!!!! message length changed while processing correlations.'
4785           call mp_stopall(Error)
4786         endif ! msglen.eq.msglen1
4787       endif ! MyRank.lt.fgProcs-1
4788       if (ldone) goto 30
4789       ldone=.true.
4790       goto 10
4791    30 continue
4792 #endif
4793       if (lprn) then
4794         write (iout,'(a)') 'Contact function values:'
4795         do i=nnt,nct-2
4796           write (iout,'(2i3,50(1x,i2,f5.2))')
4797      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4798      &    j=1,num_cont_hb(i))
4799         enddo
4800       endif
4801       ecorr=0.0D0
4802 C Remove the loop below after debugging !!!
4803       do i=nnt,nct
4804         do j=1,3
4805           gradcorr(j,i)=0.0D0
4806           gradxorr(j,i)=0.0D0
4807         enddo
4808       enddo
4809 C Calculate the local-electrostatic correlation terms
4810       do i=iatel_s,iatel_e+1
4811         i1=i+1
4812         num_conti=num_cont_hb(i)
4813         num_conti1=num_cont_hb(i+1)
4814         do jj=1,num_conti
4815           j=jcont_hb(jj,i)
4816           do kk=1,num_conti1
4817             j1=jcont_hb(kk,i1)
4818 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4819 c     &         ' jj=',jj,' kk=',kk
4820             if (j1.eq.j+1 .or. j1.eq.j-1) then
4821 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
4822 C The system gains extra energy.
4823               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
4824               n_corr=n_corr+1
4825             else if (j1.eq.j) then
4826 C Contacts I-J and I-(J+1) occur simultaneously.
4827 C The system loses extra energy.
4828 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
4829             endif
4830           enddo ! kk
4831           do kk=1,num_conti
4832             j1=jcont_hb(kk,i)
4833 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4834 c    &         ' jj=',jj,' kk=',kk
4835             if (j1.eq.j+1) then
4836 C Contacts I-J and (I+1)-J occur simultaneously.
4837 C The system loses extra energy.
4838 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
4839             endif ! j1==j+1
4840           enddo ! kk
4841         enddo ! jj
4842       enddo ! i
4843       return
4844       end
4845 c------------------------------------------------------------------------------
4846       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
4847      &  n_corr1)
4848 C This subroutine calculates multi-body contributions to hydrogen-bonding
4849       implicit real*8 (a-h,o-z)
4850       include 'DIMENSIONS'
4851       include 'sizesclu.dat'
4852       include 'COMMON.IOUNITS'
4853 #ifdef MPL
4854       include 'COMMON.INFO'
4855 #endif
4856       include 'COMMON.FFIELD'
4857       include 'COMMON.DERIV'
4858       include 'COMMON.INTERACT'
4859       include 'COMMON.CONTACTS'
4860 #ifdef MPL
4861       parameter (max_cont=maxconts)
4862       parameter (max_dim=2*(8*3+2))
4863       parameter (msglen1=max_cont*max_dim*4)
4864       parameter (msglen2=2*msglen1)
4865       integer source,CorrelType,CorrelID,Error
4866       double precision buffer(max_cont,max_dim)
4867 #endif
4868       double precision gx(3),gx1(3)
4869       logical lprn,ldone
4870
4871 C Set lprn=.true. for debugging
4872       lprn=.false.
4873       eturn6=0.0d0
4874 #ifdef MPL
4875       n_corr=0
4876       n_corr1=0
4877       if (fgProcs.le.1) goto 30
4878       if (lprn) then
4879         write (iout,'(a)') 'Contact function values:'
4880         do i=nnt,nct-2
4881           write (iout,'(2i3,50(1x,i2,f5.2))')
4882      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4883      &    j=1,num_cont_hb(i))
4884         enddo
4885       endif
4886 C Caution! Following code assumes that electrostatic interactions concerning
4887 C a given atom are split among at most two processors!
4888       CorrelType=477
4889       CorrelID=MyID+1
4890       ldone=.false.
4891       do i=1,max_cont
4892         do j=1,max_dim
4893           buffer(i,j)=0.0D0
4894         enddo
4895       enddo
4896       mm=mod(MyRank,2)
4897 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
4898       if (mm) 20,20,10
4899    10 continue
4900 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
4901       if (MyRank.gt.0) then
4902 C Send correlation contributions to the preceding processor
4903         msglen=msglen1
4904         nn=num_cont_hb(iatel_s)
4905         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
4906 cd      write (iout,*) 'The BUFFER array:'
4907 cd      do i=1,nn
4908 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
4909 cd      enddo
4910         if (ielstart(iatel_s).gt.iatel_s+ispp) then
4911           msglen=msglen2
4912             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
4913 C Clear the contacts of the atom passed to the neighboring processor
4914         nn=num_cont_hb(iatel_s+1)
4915 cd      do i=1,nn
4916 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
4917 cd      enddo
4918             num_cont_hb(iatel_s)=0
4919         endif
4920 cd      write (iout,*) 'Processor ',MyID,MyRank,
4921 cd   & ' is sending correlation contribution to processor',MyID-1,
4922 cd   & ' msglen=',msglen
4923 cd      write (*,*) 'Processor ',MyID,MyRank,
4924 cd   & ' is sending correlation contribution to processor',MyID-1,
4925 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4926         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
4927 cd      write (iout,*) 'Processor ',MyID,
4928 cd   & ' has sent correlation contribution to processor',MyID-1,
4929 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4930 cd      write (*,*) 'Processor ',MyID,
4931 cd   & ' has sent correlation contribution to processor',MyID-1,
4932 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4933         msglen=msglen1
4934       endif ! (MyRank.gt.0)
4935       if (ldone) goto 30
4936       ldone=.true.
4937    20 continue
4938 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
4939       if (MyRank.lt.fgProcs-1) then
4940 C Receive correlation contributions from the next processor
4941         msglen=msglen1
4942         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
4943 cd      write (iout,*) 'Processor',MyID,
4944 cd   & ' is receiving correlation contribution from processor',MyID+1,
4945 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4946 cd      write (*,*) 'Processor',MyID,
4947 cd   & ' is receiving correlation contribution from processor',MyID+1,
4948 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4949         nbytes=-1
4950         do while (nbytes.le.0)
4951           call mp_probe(MyID+1,CorrelType,nbytes)
4952         enddo
4953 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
4954         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
4955 cd      write (iout,*) 'Processor',MyID,
4956 cd   & ' has received correlation contribution from processor',MyID+1,
4957 cd   & ' msglen=',msglen,' nbytes=',nbytes
4958 cd      write (iout,*) 'The received BUFFER array:'
4959 cd      do i=1,max_cont
4960 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
4961 cd      enddo
4962         if (msglen.eq.msglen1) then
4963           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
4964         else if (msglen.eq.msglen2)  then
4965           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
4966           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
4967         else
4968           write (iout,*)
4969      & 'ERROR!!!! message length changed while processing correlations.'
4970           write (*,*)
4971      & 'ERROR!!!! message length changed while processing correlations.'
4972           call mp_stopall(Error)
4973         endif ! msglen.eq.msglen1
4974       endif ! MyRank.lt.fgProcs-1
4975       if (ldone) goto 30
4976       ldone=.true.
4977       goto 10
4978    30 continue
4979 #endif
4980       if (lprn) then
4981         write (iout,'(a)') 'Contact function values:'
4982         do i=nnt,nct-2
4983           write (iout,'(2i3,50(1x,i2,f5.2))')
4984      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4985      &    j=1,num_cont_hb(i))
4986         enddo
4987       endif
4988       ecorr=0.0D0
4989       ecorr5=0.0d0
4990       ecorr6=0.0d0
4991 C Remove the loop below after debugging !!!
4992       do i=nnt,nct
4993         do j=1,3
4994           gradcorr(j,i)=0.0D0
4995           gradxorr(j,i)=0.0D0
4996         enddo
4997       enddo
4998 C Calculate the dipole-dipole interaction energies
4999       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5000       do i=iatel_s,iatel_e+1
5001         num_conti=num_cont_hb(i)
5002         do jj=1,num_conti
5003           j=jcont_hb(jj,i)
5004           call dipole(i,j,jj)
5005         enddo
5006       enddo
5007       endif
5008 C Calculate the local-electrostatic correlation terms
5009       do i=iatel_s,iatel_e+1
5010         i1=i+1
5011         num_conti=num_cont_hb(i)
5012         num_conti1=num_cont_hb(i+1)
5013         do jj=1,num_conti
5014           j=jcont_hb(jj,i)
5015           do kk=1,num_conti1
5016             j1=jcont_hb(kk,i1)
5017 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5018 c     &         ' jj=',jj,' kk=',kk
5019             if (j1.eq.j+1 .or. j1.eq.j-1) then
5020 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5021 C The system gains extra energy.
5022               n_corr=n_corr+1
5023               sqd1=dsqrt(d_cont(jj,i))
5024               sqd2=dsqrt(d_cont(kk,i1))
5025               sred_geom = sqd1*sqd2
5026               IF (sred_geom.lt.cutoff_corr) THEN
5027                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5028      &            ekont,fprimcont)
5029 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5030 c     &         ' jj=',jj,' kk=',kk
5031                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5032                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5033                 do l=1,3
5034                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5035                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5036                 enddo
5037                 n_corr1=n_corr1+1
5038 cd               write (iout,*) 'sred_geom=',sred_geom,
5039 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5040                 call calc_eello(i,j,i+1,j1,jj,kk)
5041                 if (wcorr4.gt.0.0d0)
5042      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5043                 if (wcorr5.gt.0.0d0)
5044      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5045 c                print *,"wcorr5",ecorr5
5046 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5047 cd                write(2,*)'ijkl',i,j,i+1,j1
5048                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5049      &               .or. wturn6.eq.0.0d0))then
5050 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5051                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5052 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5053 cd     &            'ecorr6=',ecorr6
5054 cd                write (iout,'(4e15.5)') sred_geom,
5055 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5056 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5057 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5058                 else if (wturn6.gt.0.0d0
5059      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5060 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5061                   eturn6=eturn6+eello_turn6(i,jj,kk)
5062 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5063                 endif
5064               ENDIF
5065 1111          continue
5066             else if (j1.eq.j) then
5067 C Contacts I-J and I-(J+1) occur simultaneously.
5068 C The system loses extra energy.
5069 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5070             endif
5071           enddo ! kk
5072           do kk=1,num_conti
5073             j1=jcont_hb(kk,i)
5074 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5075 c    &         ' jj=',jj,' kk=',kk
5076             if (j1.eq.j+1) then
5077 C Contacts I-J and (I+1)-J occur simultaneously.
5078 C The system loses extra energy.
5079 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5080             endif ! j1==j+1
5081           enddo ! kk
5082         enddo ! jj
5083       enddo ! i
5084       return
5085       end
5086 c------------------------------------------------------------------------------
5087       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5088       implicit real*8 (a-h,o-z)
5089       include 'DIMENSIONS'
5090       include 'COMMON.IOUNITS'
5091       include 'COMMON.DERIV'
5092       include 'COMMON.INTERACT'
5093       include 'COMMON.CONTACTS'
5094       double precision gx(3),gx1(3)
5095       logical lprn
5096       lprn=.false.
5097       eij=facont_hb(jj,i)
5098       ekl=facont_hb(kk,k)
5099       ees0pij=ees0p(jj,i)
5100       ees0pkl=ees0p(kk,k)
5101       ees0mij=ees0m(jj,i)
5102       ees0mkl=ees0m(kk,k)
5103       ekont=eij*ekl
5104       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5105 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5106 C Following 4 lines for diagnostics.
5107 cd    ees0pkl=0.0D0
5108 cd    ees0pij=1.0D0
5109 cd    ees0mkl=0.0D0
5110 cd    ees0mij=1.0D0
5111 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5112 c    &   ' and',k,l
5113 c     write (iout,*)'Contacts have occurred for peptide groups',
5114 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5115 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5116 C Calculate the multi-body contribution to energy.
5117       ecorr=ecorr+ekont*ees
5118       if (calc_grad) then
5119 C Calculate multi-body contributions to the gradient.
5120       do ll=1,3
5121         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5122         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5123      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5124      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5125         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5126      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5127      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5128         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5129         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5130      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5131      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5132         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5133      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5134      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5135       enddo
5136       do m=i+1,j-1
5137         do ll=1,3
5138           gradcorr(ll,m)=gradcorr(ll,m)+
5139      &     ees*ekl*gacont_hbr(ll,jj,i)-
5140      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5141      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5142         enddo
5143       enddo
5144       do m=k+1,l-1
5145         do ll=1,3
5146           gradcorr(ll,m)=gradcorr(ll,m)+
5147      &     ees*eij*gacont_hbr(ll,kk,k)-
5148      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5149      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5150         enddo
5151       enddo
5152       endif
5153       ehbcorr=ekont*ees
5154       return
5155       end
5156 C---------------------------------------------------------------------------
5157       subroutine dipole(i,j,jj)
5158       implicit real*8 (a-h,o-z)
5159       include 'DIMENSIONS'
5160       include 'sizesclu.dat'
5161       include 'COMMON.IOUNITS'
5162       include 'COMMON.CHAIN'
5163       include 'COMMON.FFIELD'
5164       include 'COMMON.DERIV'
5165       include 'COMMON.INTERACT'
5166       include 'COMMON.CONTACTS'
5167       include 'COMMON.TORSION'
5168       include 'COMMON.VAR'
5169       include 'COMMON.GEO'
5170       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5171      &  auxmat(2,2)
5172       iti1 = itortyp(itype(i+1))
5173       if (j.lt.nres-1) then
5174         itj1 = itortyp(itype(j+1))
5175       else
5176         itj1=ntortyp+1
5177       endif
5178       do iii=1,2
5179         dipi(iii,1)=Ub2(iii,i)
5180         dipderi(iii)=Ub2der(iii,i)
5181         dipi(iii,2)=b1(iii,iti1)
5182         dipj(iii,1)=Ub2(iii,j)
5183         dipderj(iii)=Ub2der(iii,j)
5184         dipj(iii,2)=b1(iii,itj1)
5185       enddo
5186       kkk=0
5187       do iii=1,2
5188         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5189         do jjj=1,2
5190           kkk=kkk+1
5191           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5192         enddo
5193       enddo
5194       if (.not.calc_grad) return
5195       do kkk=1,5
5196         do lll=1,3
5197           mmm=0
5198           do iii=1,2
5199             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5200      &        auxvec(1))
5201             do jjj=1,2
5202               mmm=mmm+1
5203               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5204             enddo
5205           enddo
5206         enddo
5207       enddo
5208       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5209       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5210       do iii=1,2
5211         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5212       enddo
5213       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5214       do iii=1,2
5215         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5216       enddo
5217       return
5218       end
5219 C---------------------------------------------------------------------------
5220       subroutine calc_eello(i,j,k,l,jj,kk)
5221 C
5222 C This subroutine computes matrices and vectors needed to calculate
5223 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5224 C
5225       implicit real*8 (a-h,o-z)
5226       include 'DIMENSIONS'
5227       include 'sizesclu.dat'
5228       include 'COMMON.IOUNITS'
5229       include 'COMMON.CHAIN'
5230       include 'COMMON.DERIV'
5231       include 'COMMON.INTERACT'
5232       include 'COMMON.CONTACTS'
5233       include 'COMMON.TORSION'
5234       include 'COMMON.VAR'
5235       include 'COMMON.GEO'
5236       include 'COMMON.FFIELD'
5237       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5238      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5239       logical lprn
5240       common /kutas/ lprn
5241 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5242 cd     & ' jj=',jj,' kk=',kk
5243 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5244       do iii=1,2
5245         do jjj=1,2
5246           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5247           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5248         enddo
5249       enddo
5250       call transpose2(aa1(1,1),aa1t(1,1))
5251       call transpose2(aa2(1,1),aa2t(1,1))
5252       do kkk=1,5
5253         do lll=1,3
5254           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5255      &      aa1tder(1,1,lll,kkk))
5256           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5257      &      aa2tder(1,1,lll,kkk))
5258         enddo
5259       enddo
5260       if (l.eq.j+1) then
5261 C parallel orientation of the two CA-CA-CA frames.
5262         if (i.gt.1) then
5263           iti=itortyp(itype(i))
5264         else
5265           iti=ntortyp+1
5266         endif
5267         itk1=itortyp(itype(k+1))
5268         itj=itortyp(itype(j))
5269         if (l.lt.nres-1) then
5270           itl1=itortyp(itype(l+1))
5271         else
5272           itl1=ntortyp+1
5273         endif
5274 C A1 kernel(j+1) A2T
5275 cd        do iii=1,2
5276 cd          write (iout,'(3f10.5,5x,3f10.5)')
5277 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5278 cd        enddo
5279         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5280      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5281      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5282 C Following matrices are needed only for 6-th order cumulants
5283         IF (wcorr6.gt.0.0d0) THEN
5284         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5285      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5286      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5287         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5288      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5289      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5290      &   ADtEAderx(1,1,1,1,1,1))
5291         lprn=.false.
5292         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5293      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5294      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5295      &   ADtEA1derx(1,1,1,1,1,1))
5296         ENDIF
5297 C End 6-th order cumulants
5298 cd        lprn=.false.
5299 cd        if (lprn) then
5300 cd        write (2,*) 'In calc_eello6'
5301 cd        do iii=1,2
5302 cd          write (2,*) 'iii=',iii
5303 cd          do kkk=1,5
5304 cd            write (2,*) 'kkk=',kkk
5305 cd            do jjj=1,2
5306 cd              write (2,'(3(2f10.5),5x)')
5307 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5308 cd            enddo
5309 cd          enddo
5310 cd        enddo
5311 cd        endif
5312         call transpose2(EUgder(1,1,k),auxmat(1,1))
5313         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5314         call transpose2(EUg(1,1,k),auxmat(1,1))
5315         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5316         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5317         do iii=1,2
5318           do kkk=1,5
5319             do lll=1,3
5320               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5321      &          EAEAderx(1,1,lll,kkk,iii,1))
5322             enddo
5323           enddo
5324         enddo
5325 C A1T kernel(i+1) A2
5326         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5327      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5328      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5329 C Following matrices are needed only for 6-th order cumulants
5330         IF (wcorr6.gt.0.0d0) THEN
5331         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5332      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5333      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5334         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5335      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
5336      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5337      &   ADtEAderx(1,1,1,1,1,2))
5338         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5339      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5340      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5341      &   ADtEA1derx(1,1,1,1,1,2))
5342         ENDIF
5343 C End 6-th order cumulants
5344         call transpose2(EUgder(1,1,l),auxmat(1,1))
5345         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5346         call transpose2(EUg(1,1,l),auxmat(1,1))
5347         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5348         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5349         do iii=1,2
5350           do kkk=1,5
5351             do lll=1,3
5352               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5353      &          EAEAderx(1,1,lll,kkk,iii,2))
5354             enddo
5355           enddo
5356         enddo
5357 C AEAb1 and AEAb2
5358 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5359 C They are needed only when the fifth- or the sixth-order cumulants are
5360 C indluded.
5361         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5362         call transpose2(AEA(1,1,1),auxmat(1,1))
5363         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5364         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5365         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5366         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5367         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5368         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5369         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5370         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5371         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5372         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5373         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5374         call transpose2(AEA(1,1,2),auxmat(1,1))
5375         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5376         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5377         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5378         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5379         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5380         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5381         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5382         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5383         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5384         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5385         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5386 C Calculate the Cartesian derivatives of the vectors.
5387         do iii=1,2
5388           do kkk=1,5
5389             do lll=1,3
5390               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5391               call matvec2(auxmat(1,1),b1(1,iti),
5392      &          AEAb1derx(1,lll,kkk,iii,1,1))
5393               call matvec2(auxmat(1,1),Ub2(1,i),
5394      &          AEAb2derx(1,lll,kkk,iii,1,1))
5395               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5396      &          AEAb1derx(1,lll,kkk,iii,2,1))
5397               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5398      &          AEAb2derx(1,lll,kkk,iii,2,1))
5399               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5400               call matvec2(auxmat(1,1),b1(1,itj),
5401      &          AEAb1derx(1,lll,kkk,iii,1,2))
5402               call matvec2(auxmat(1,1),Ub2(1,j),
5403      &          AEAb2derx(1,lll,kkk,iii,1,2))
5404               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
5405      &          AEAb1derx(1,lll,kkk,iii,2,2))
5406               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
5407      &          AEAb2derx(1,lll,kkk,iii,2,2))
5408             enddo
5409           enddo
5410         enddo
5411         ENDIF
5412 C End vectors
5413       else
5414 C Antiparallel orientation of the two CA-CA-CA frames.
5415         if (i.gt.1) then
5416           iti=itortyp(itype(i))
5417         else
5418           iti=ntortyp+1
5419         endif
5420         itk1=itortyp(itype(k+1))
5421         itl=itortyp(itype(l))
5422         itj=itortyp(itype(j))
5423         if (j.lt.nres-1) then
5424           itj1=itortyp(itype(j+1))
5425         else
5426           itj1=ntortyp+1
5427         endif
5428 C A2 kernel(j-1)T A1T
5429         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5430      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
5431      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5432 C Following matrices are needed only for 6-th order cumulants
5433         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5434      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5435         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5436      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
5437      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5438         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5439      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
5440      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5441      &   ADtEAderx(1,1,1,1,1,1))
5442         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5443      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
5444      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5445      &   ADtEA1derx(1,1,1,1,1,1))
5446         ENDIF
5447 C End 6-th order cumulants
5448         call transpose2(EUgder(1,1,k),auxmat(1,1))
5449         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5450         call transpose2(EUg(1,1,k),auxmat(1,1))
5451         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5452         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5453         do iii=1,2
5454           do kkk=1,5
5455             do lll=1,3
5456               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5457      &          EAEAderx(1,1,lll,kkk,iii,1))
5458             enddo
5459           enddo
5460         enddo
5461 C A2T kernel(i+1)T A1
5462         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5463      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
5464      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5465 C Following matrices are needed only for 6-th order cumulants
5466         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5467      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5468         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5469      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
5470      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5471         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5472      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
5473      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5474      &   ADtEAderx(1,1,1,1,1,2))
5475         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5476      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
5477      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5478      &   ADtEA1derx(1,1,1,1,1,2))
5479         ENDIF
5480 C End 6-th order cumulants
5481         call transpose2(EUgder(1,1,j),auxmat(1,1))
5482         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
5483         call transpose2(EUg(1,1,j),auxmat(1,1))
5484         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5485         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5486         do iii=1,2
5487           do kkk=1,5
5488             do lll=1,3
5489               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5490      &          EAEAderx(1,1,lll,kkk,iii,2))
5491             enddo
5492           enddo
5493         enddo
5494 C AEAb1 and AEAb2
5495 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5496 C They are needed only when the fifth- or the sixth-order cumulants are
5497 C indluded.
5498         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
5499      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
5500         call transpose2(AEA(1,1,1),auxmat(1,1))
5501         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5502         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5503         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5504         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5505         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5506         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5507         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5508         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5509         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5510         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5511         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5512         call transpose2(AEA(1,1,2),auxmat(1,1))
5513         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
5514         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
5515         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
5516         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5517         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
5518         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
5519         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
5520         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
5521         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
5522         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
5523         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
5524 C Calculate the Cartesian derivatives of the vectors.
5525         do iii=1,2
5526           do kkk=1,5
5527             do lll=1,3
5528               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5529               call matvec2(auxmat(1,1),b1(1,iti),
5530      &          AEAb1derx(1,lll,kkk,iii,1,1))
5531               call matvec2(auxmat(1,1),Ub2(1,i),
5532      &          AEAb2derx(1,lll,kkk,iii,1,1))
5533               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5534      &          AEAb1derx(1,lll,kkk,iii,2,1))
5535               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5536      &          AEAb2derx(1,lll,kkk,iii,2,1))
5537               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5538               call matvec2(auxmat(1,1),b1(1,itl),
5539      &          AEAb1derx(1,lll,kkk,iii,1,2))
5540               call matvec2(auxmat(1,1),Ub2(1,l),
5541      &          AEAb2derx(1,lll,kkk,iii,1,2))
5542               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
5543      &          AEAb1derx(1,lll,kkk,iii,2,2))
5544               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
5545      &          AEAb2derx(1,lll,kkk,iii,2,2))
5546             enddo
5547           enddo
5548         enddo
5549         ENDIF
5550 C End vectors
5551       endif
5552       return
5553       end
5554 C---------------------------------------------------------------------------
5555       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
5556      &  KK,KKderg,AKA,AKAderg,AKAderx)
5557       implicit none
5558       integer nderg
5559       logical transp
5560       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
5561      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
5562      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
5563       integer iii,kkk,lll
5564       integer jjj,mmm
5565       logical lprn
5566       common /kutas/ lprn
5567       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
5568       do iii=1,nderg
5569         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
5570      &    AKAderg(1,1,iii))
5571       enddo
5572 cd      if (lprn) write (2,*) 'In kernel'
5573       do kkk=1,5
5574 cd        if (lprn) write (2,*) 'kkk=',kkk
5575         do lll=1,3
5576           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
5577      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
5578 cd          if (lprn) then
5579 cd            write (2,*) 'lll=',lll
5580 cd            write (2,*) 'iii=1'
5581 cd            do jjj=1,2
5582 cd              write (2,'(3(2f10.5),5x)')
5583 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
5584 cd            enddo
5585 cd          endif
5586           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
5587      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
5588 cd          if (lprn) then
5589 cd            write (2,*) 'lll=',lll
5590 cd            write (2,*) 'iii=2'
5591 cd            do jjj=1,2
5592 cd              write (2,'(3(2f10.5),5x)')
5593 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
5594 cd            enddo
5595 cd          endif
5596         enddo
5597       enddo
5598       return
5599       end
5600 C---------------------------------------------------------------------------
5601       double precision function eello4(i,j,k,l,jj,kk)
5602       implicit real*8 (a-h,o-z)
5603       include 'DIMENSIONS'
5604       include 'sizesclu.dat'
5605       include 'COMMON.IOUNITS'
5606       include 'COMMON.CHAIN'
5607       include 'COMMON.DERIV'
5608       include 'COMMON.INTERACT'
5609       include 'COMMON.CONTACTS'
5610       include 'COMMON.TORSION'
5611       include 'COMMON.VAR'
5612       include 'COMMON.GEO'
5613       double precision pizda(2,2),ggg1(3),ggg2(3)
5614 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
5615 cd        eello4=0.0d0
5616 cd        return
5617 cd      endif
5618 cd      print *,'eello4:',i,j,k,l,jj,kk
5619 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
5620 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
5621 cold      eij=facont_hb(jj,i)
5622 cold      ekl=facont_hb(kk,k)
5623 cold      ekont=eij*ekl
5624       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
5625       if (calc_grad) then
5626 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
5627       gcorr_loc(k-1)=gcorr_loc(k-1)
5628      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
5629       if (l.eq.j+1) then
5630         gcorr_loc(l-1)=gcorr_loc(l-1)
5631      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5632       else
5633         gcorr_loc(j-1)=gcorr_loc(j-1)
5634      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5635       endif
5636       do iii=1,2
5637         do kkk=1,5
5638           do lll=1,3
5639             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
5640      &                        -EAEAderx(2,2,lll,kkk,iii,1)
5641 cd            derx(lll,kkk,iii)=0.0d0
5642           enddo
5643         enddo
5644       enddo
5645 cd      gcorr_loc(l-1)=0.0d0
5646 cd      gcorr_loc(j-1)=0.0d0
5647 cd      gcorr_loc(k-1)=0.0d0
5648 cd      eel4=1.0d0
5649 cd      write (iout,*)'Contacts have occurred for peptide groups',
5650 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
5651 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
5652       if (j.lt.nres-1) then
5653         j1=j+1
5654         j2=j-1
5655       else
5656         j1=j-1
5657         j2=j-2
5658       endif
5659       if (l.lt.nres-1) then
5660         l1=l+1
5661         l2=l-1
5662       else
5663         l1=l-1
5664         l2=l-2
5665       endif
5666       do ll=1,3
5667 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
5668         ggg1(ll)=eel4*g_contij(ll,1)
5669         ggg2(ll)=eel4*g_contij(ll,2)
5670         ghalf=0.5d0*ggg1(ll)
5671 cd        ghalf=0.0d0
5672         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
5673         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
5674         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
5675         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
5676 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
5677         ghalf=0.5d0*ggg2(ll)
5678 cd        ghalf=0.0d0
5679         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
5680         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
5681         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
5682         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
5683       enddo
5684 cd      goto 1112
5685       do m=i+1,j-1
5686         do ll=1,3
5687 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
5688           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
5689         enddo
5690       enddo
5691       do m=k+1,l-1
5692         do ll=1,3
5693 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
5694           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
5695         enddo
5696       enddo
5697 1112  continue
5698       do m=i+2,j2
5699         do ll=1,3
5700           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
5701         enddo
5702       enddo
5703       do m=k+2,l2
5704         do ll=1,3
5705           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
5706         enddo
5707       enddo
5708 cd      do iii=1,nres-3
5709 cd        write (2,*) iii,gcorr_loc(iii)
5710 cd      enddo
5711       endif
5712       eello4=ekont*eel4
5713 cd      write (2,*) 'ekont',ekont
5714 cd      write (iout,*) 'eello4',ekont*eel4
5715       return
5716       end
5717 C---------------------------------------------------------------------------
5718       double precision function eello5(i,j,k,l,jj,kk)
5719       implicit real*8 (a-h,o-z)
5720       include 'DIMENSIONS'
5721       include 'sizesclu.dat'
5722       include 'COMMON.IOUNITS'
5723       include 'COMMON.CHAIN'
5724       include 'COMMON.DERIV'
5725       include 'COMMON.INTERACT'
5726       include 'COMMON.CONTACTS'
5727       include 'COMMON.TORSION'
5728       include 'COMMON.VAR'
5729       include 'COMMON.GEO'
5730       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
5731       double precision ggg1(3),ggg2(3)
5732 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5733 C                                                                              C
5734 C                            Parallel chains                                   C
5735 C                                                                              C
5736 C          o             o                   o             o                   C
5737 C         /l\           / \             \   / \           / \   /              C
5738 C        /   \         /   \             \ /   \         /   \ /               C
5739 C       j| o |l1       | o |              o| o |         | o |o                C
5740 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
5741 C      \i/   \         /   \ /             /   \         /   \                 C
5742 C       o    k1             o                                                  C
5743 C         (I)          (II)                (III)          (IV)                 C
5744 C                                                                              C
5745 C      eello5_1        eello5_2            eello5_3       eello5_4             C
5746 C                                                                              C
5747 C                            Antiparallel chains                               C
5748 C                                                                              C
5749 C          o             o                   o             o                   C
5750 C         /j\           / \             \   / \           / \   /              C
5751 C        /   \         /   \             \ /   \         /   \ /               C
5752 C      j1| o |l        | o |              o| o |         | o |o                C
5753 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
5754 C      \i/   \         /   \ /             /   \         /   \                 C
5755 C       o     k1            o                                                  C
5756 C         (I)          (II)                (III)          (IV)                 C
5757 C                                                                              C
5758 C      eello5_1        eello5_2            eello5_3       eello5_4             C
5759 C                                                                              C
5760 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
5761 C                                                                              C
5762 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5763 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
5764 cd        eello5=0.0d0
5765 cd        return
5766 cd      endif
5767 cd      write (iout,*)
5768 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
5769 cd     &   ' and',k,l
5770       itk=itortyp(itype(k))
5771       itl=itortyp(itype(l))
5772       itj=itortyp(itype(j))
5773       eello5_1=0.0d0
5774       eello5_2=0.0d0
5775       eello5_3=0.0d0
5776       eello5_4=0.0d0
5777 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
5778 cd     &   eel5_3_num,eel5_4_num)
5779       do iii=1,2
5780         do kkk=1,5
5781           do lll=1,3
5782             derx(lll,kkk,iii)=0.0d0
5783           enddo
5784         enddo
5785       enddo
5786 cd      eij=facont_hb(jj,i)
5787 cd      ekl=facont_hb(kk,k)
5788 cd      ekont=eij*ekl
5789 cd      write (iout,*)'Contacts have occurred for peptide groups',
5790 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
5791 cd      goto 1111
5792 C Contribution from the graph I.
5793 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
5794 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
5795       call transpose2(EUg(1,1,k),auxmat(1,1))
5796       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
5797       vv(1)=pizda(1,1)-pizda(2,2)
5798       vv(2)=pizda(1,2)+pizda(2,1)
5799       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
5800      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
5801       if (calc_grad) then
5802 C Explicit gradient in virtual-dihedral angles.
5803       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
5804      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
5805      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
5806       call transpose2(EUgder(1,1,k),auxmat1(1,1))
5807       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
5808       vv(1)=pizda(1,1)-pizda(2,2)
5809       vv(2)=pizda(1,2)+pizda(2,1)
5810       g_corr5_loc(k-1)=g_corr5_loc(k-1)
5811      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
5812      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5813       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
5814       vv(1)=pizda(1,1)-pizda(2,2)
5815       vv(2)=pizda(1,2)+pizda(2,1)
5816       if (l.eq.j+1) then
5817         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
5818      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
5819      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5820       else
5821         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
5822      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
5823      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5824       endif
5825 C Cartesian gradient
5826       do iii=1,2
5827         do kkk=1,5
5828           do lll=1,3
5829             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
5830      &        pizda(1,1))
5831             vv(1)=pizda(1,1)-pizda(2,2)
5832             vv(2)=pizda(1,2)+pizda(2,1)
5833             derx(lll,kkk,iii)=derx(lll,kkk,iii)
5834      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
5835      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
5836           enddo
5837         enddo
5838       enddo
5839 c      goto 1112
5840       endif
5841 c1111  continue
5842 C Contribution from graph II
5843       call transpose2(EE(1,1,itk),auxmat(1,1))
5844       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
5845       vv(1)=pizda(1,1)+pizda(2,2)
5846       vv(2)=pizda(2,1)-pizda(1,2)
5847       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
5848      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
5849       if (calc_grad) then
5850 C Explicit gradient in virtual-dihedral angles.
5851       g_corr5_loc(k-1)=g_corr5_loc(k-1)
5852      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
5853       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
5854       vv(1)=pizda(1,1)+pizda(2,2)
5855       vv(2)=pizda(2,1)-pizda(1,2)
5856       if (l.eq.j+1) then
5857         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5858      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
5859      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
5860       else
5861         g_corr5_loc(j-1)=g_corr5_loc(j-1)
5862      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
5863      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
5864       endif
5865 C Cartesian gradient
5866       do iii=1,2
5867         do kkk=1,5
5868           do lll=1,3
5869             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5870      &        pizda(1,1))
5871             vv(1)=pizda(1,1)+pizda(2,2)
5872             vv(2)=pizda(2,1)-pizda(1,2)
5873             derx(lll,kkk,iii)=derx(lll,kkk,iii)
5874      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
5875      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
5876           enddo
5877         enddo
5878       enddo
5879 cd      goto 1112
5880       endif
5881 cd1111  continue
5882       if (l.eq.j+1) then
5883 cd        goto 1110
5884 C Parallel orientation
5885 C Contribution from graph III
5886         call transpose2(EUg(1,1,l),auxmat(1,1))
5887         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
5888         vv(1)=pizda(1,1)-pizda(2,2)
5889         vv(2)=pizda(1,2)+pizda(2,1)
5890         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
5891      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
5892         if (calc_grad) then
5893 C Explicit gradient in virtual-dihedral angles.
5894         g_corr5_loc(j-1)=g_corr5_loc(j-1)
5895      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
5896      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
5897         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
5898         vv(1)=pizda(1,1)-pizda(2,2)
5899         vv(2)=pizda(1,2)+pizda(2,1)
5900         g_corr5_loc(k-1)=g_corr5_loc(k-1)
5901      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
5902      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
5903         call transpose2(EUgder(1,1,l),auxmat1(1,1))
5904         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
5905         vv(1)=pizda(1,1)-pizda(2,2)
5906         vv(2)=pizda(1,2)+pizda(2,1)
5907         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5908      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
5909      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
5910 C Cartesian gradient
5911         do iii=1,2
5912           do kkk=1,5
5913             do lll=1,3
5914               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
5915      &          pizda(1,1))
5916               vv(1)=pizda(1,1)-pizda(2,2)
5917               vv(2)=pizda(1,2)+pizda(2,1)
5918               derx(lll,kkk,iii)=derx(lll,kkk,iii)
5919      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
5920      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
5921             enddo
5922           enddo
5923         enddo
5924 cd        goto 1112
5925         endif
5926 C Contribution from graph IV
5927 cd1110    continue
5928         call transpose2(EE(1,1,itl),auxmat(1,1))
5929         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
5930         vv(1)=pizda(1,1)+pizda(2,2)
5931         vv(2)=pizda(2,1)-pizda(1,2)
5932         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
5933      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
5934         if (calc_grad) then
5935 C Explicit gradient in virtual-dihedral angles.
5936         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5937      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
5938         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
5939         vv(1)=pizda(1,1)+pizda(2,2)
5940         vv(2)=pizda(2,1)-pizda(1,2)
5941         g_corr5_loc(k-1)=g_corr5_loc(k-1)
5942      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
5943      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
5944 C Cartesian gradient
5945         do iii=1,2
5946           do kkk=1,5
5947             do lll=1,3
5948               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5949      &          pizda(1,1))
5950               vv(1)=pizda(1,1)+pizda(2,2)
5951               vv(2)=pizda(2,1)-pizda(1,2)
5952               derx(lll,kkk,iii)=derx(lll,kkk,iii)
5953      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
5954      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
5955             enddo
5956           enddo
5957         enddo
5958         endif
5959       else
5960 C Antiparallel orientation
5961 C Contribution from graph III
5962 c        goto 1110
5963         call transpose2(EUg(1,1,j),auxmat(1,1))
5964         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
5965         vv(1)=pizda(1,1)-pizda(2,2)
5966         vv(2)=pizda(1,2)+pizda(2,1)
5967         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
5968      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
5969         if (calc_grad) then
5970 C Explicit gradient in virtual-dihedral angles.
5971         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5972      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
5973      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
5974         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
5975         vv(1)=pizda(1,1)-pizda(2,2)
5976         vv(2)=pizda(1,2)+pizda(2,1)
5977         g_corr5_loc(k-1)=g_corr5_loc(k-1)
5978      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
5979      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
5980         call transpose2(EUgder(1,1,j),auxmat1(1,1))
5981         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
5982         vv(1)=pizda(1,1)-pizda(2,2)
5983         vv(2)=pizda(1,2)+pizda(2,1)
5984         g_corr5_loc(j-1)=g_corr5_loc(j-1)
5985      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
5986      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
5987 C Cartesian gradient
5988         do iii=1,2
5989           do kkk=1,5
5990             do lll=1,3
5991               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
5992      &          pizda(1,1))
5993               vv(1)=pizda(1,1)-pizda(2,2)
5994               vv(2)=pizda(1,2)+pizda(2,1)
5995               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
5996      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
5997      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
5998             enddo
5999           enddo
6000         enddo
6001 cd        goto 1112
6002         endif
6003 C Contribution from graph IV
6004 1110    continue
6005         call transpose2(EE(1,1,itj),auxmat(1,1))
6006         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6007         vv(1)=pizda(1,1)+pizda(2,2)
6008         vv(2)=pizda(2,1)-pizda(1,2)
6009         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6010      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6011         if (calc_grad) then
6012 C Explicit gradient in virtual-dihedral angles.
6013         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6014      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6015         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6016         vv(1)=pizda(1,1)+pizda(2,2)
6017         vv(2)=pizda(2,1)-pizda(1,2)
6018         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6019      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6020      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6021 C Cartesian gradient
6022         do iii=1,2
6023           do kkk=1,5
6024             do lll=1,3
6025               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6026      &          pizda(1,1))
6027               vv(1)=pizda(1,1)+pizda(2,2)
6028               vv(2)=pizda(2,1)-pizda(1,2)
6029               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6030      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6031      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6032             enddo
6033           enddo
6034         enddo
6035       endif
6036       endif
6037 1112  continue
6038       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6039 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6040 cd        write (2,*) 'ijkl',i,j,k,l
6041 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6042 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6043 cd      endif
6044 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6045 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6046 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6047 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6048       if (calc_grad) then
6049       if (j.lt.nres-1) then
6050         j1=j+1
6051         j2=j-1
6052       else
6053         j1=j-1
6054         j2=j-2
6055       endif
6056       if (l.lt.nres-1) then
6057         l1=l+1
6058         l2=l-1
6059       else
6060         l1=l-1
6061         l2=l-2
6062       endif
6063 cd      eij=1.0d0
6064 cd      ekl=1.0d0
6065 cd      ekont=1.0d0
6066 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6067       do ll=1,3
6068         ggg1(ll)=eel5*g_contij(ll,1)
6069         ggg2(ll)=eel5*g_contij(ll,2)
6070 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6071         ghalf=0.5d0*ggg1(ll)
6072 cd        ghalf=0.0d0
6073         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6074         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6075         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6076         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6077 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6078         ghalf=0.5d0*ggg2(ll)
6079 cd        ghalf=0.0d0
6080         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6081         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6082         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6083         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6084       enddo
6085 cd      goto 1112
6086       do m=i+1,j-1
6087         do ll=1,3
6088 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6089           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6090         enddo
6091       enddo
6092       do m=k+1,l-1
6093         do ll=1,3
6094 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6095           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6096         enddo
6097       enddo
6098 c1112  continue
6099       do m=i+2,j2
6100         do ll=1,3
6101           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6102         enddo
6103       enddo
6104       do m=k+2,l2
6105         do ll=1,3
6106           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6107         enddo
6108       enddo
6109 cd      do iii=1,nres-3
6110 cd        write (2,*) iii,g_corr5_loc(iii)
6111 cd      enddo
6112       endif
6113       eello5=ekont*eel5
6114 cd      write (2,*) 'ekont',ekont
6115 cd      write (iout,*) 'eello5',ekont*eel5
6116       return
6117       end
6118 c--------------------------------------------------------------------------
6119       double precision function eello6(i,j,k,l,jj,kk)
6120       implicit real*8 (a-h,o-z)
6121       include 'DIMENSIONS'
6122       include 'sizesclu.dat'
6123       include 'COMMON.IOUNITS'
6124       include 'COMMON.CHAIN'
6125       include 'COMMON.DERIV'
6126       include 'COMMON.INTERACT'
6127       include 'COMMON.CONTACTS'
6128       include 'COMMON.TORSION'
6129       include 'COMMON.VAR'
6130       include 'COMMON.GEO'
6131       include 'COMMON.FFIELD'
6132       double precision ggg1(3),ggg2(3)
6133 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6134 cd        eello6=0.0d0
6135 cd        return
6136 cd      endif
6137 cd      write (iout,*)
6138 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6139 cd     &   ' and',k,l
6140       eello6_1=0.0d0
6141       eello6_2=0.0d0
6142       eello6_3=0.0d0
6143       eello6_4=0.0d0
6144       eello6_5=0.0d0
6145       eello6_6=0.0d0
6146 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6147 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6148       do iii=1,2
6149         do kkk=1,5
6150           do lll=1,3
6151             derx(lll,kkk,iii)=0.0d0
6152           enddo
6153         enddo
6154       enddo
6155 cd      eij=facont_hb(jj,i)
6156 cd      ekl=facont_hb(kk,k)
6157 cd      ekont=eij*ekl
6158 cd      eij=1.0d0
6159 cd      ekl=1.0d0
6160 cd      ekont=1.0d0
6161       if (l.eq.j+1) then
6162         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6163         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6164         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6165         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6166         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6167         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6168       else
6169         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6170         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6171         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6172         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6173         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6174           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6175         else
6176           eello6_5=0.0d0
6177         endif
6178         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6179       endif
6180 C If turn contributions are considered, they will be handled separately.
6181       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6182 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6183 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6184 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6185 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6186 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6187 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6188 cd      goto 1112
6189       if (calc_grad) then
6190       if (j.lt.nres-1) then
6191         j1=j+1
6192         j2=j-1
6193       else
6194         j1=j-1
6195         j2=j-2
6196       endif
6197       if (l.lt.nres-1) then
6198         l1=l+1
6199         l2=l-1
6200       else
6201         l1=l-1
6202         l2=l-2
6203       endif
6204       do ll=1,3
6205         ggg1(ll)=eel6*g_contij(ll,1)
6206         ggg2(ll)=eel6*g_contij(ll,2)
6207 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6208         ghalf=0.5d0*ggg1(ll)
6209 cd        ghalf=0.0d0
6210         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6211         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6212         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6213         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6214         ghalf=0.5d0*ggg2(ll)
6215 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6216 cd        ghalf=0.0d0
6217         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6218         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6219         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6220         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6221       enddo
6222 cd      goto 1112
6223       do m=i+1,j-1
6224         do ll=1,3
6225 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6226           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6227         enddo
6228       enddo
6229       do m=k+1,l-1
6230         do ll=1,3
6231 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6232           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6233         enddo
6234       enddo
6235 1112  continue
6236       do m=i+2,j2
6237         do ll=1,3
6238           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6239         enddo
6240       enddo
6241       do m=k+2,l2
6242         do ll=1,3
6243           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6244         enddo
6245       enddo
6246 cd      do iii=1,nres-3
6247 cd        write (2,*) iii,g_corr6_loc(iii)
6248 cd      enddo
6249       endif
6250       eello6=ekont*eel6
6251 cd      write (2,*) 'ekont',ekont
6252 cd      write (iout,*) 'eello6',ekont*eel6
6253       return
6254       end
6255 c--------------------------------------------------------------------------
6256       double precision function eello6_graph1(i,j,k,l,imat,swap)
6257       implicit real*8 (a-h,o-z)
6258       include 'DIMENSIONS'
6259       include 'sizesclu.dat'
6260       include 'COMMON.IOUNITS'
6261       include 'COMMON.CHAIN'
6262       include 'COMMON.DERIV'
6263       include 'COMMON.INTERACT'
6264       include 'COMMON.CONTACTS'
6265       include 'COMMON.TORSION'
6266       include 'COMMON.VAR'
6267       include 'COMMON.GEO'
6268       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6269       logical swap
6270       logical lprn
6271       common /kutas/ lprn
6272 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6273 C
6274 C      Parallel       Antiparallel
6275 C
6276 C          o             o
6277 C         /l\           /j\
6278 C        /   \         /   \
6279 C       /| o |         | o |\
6280 C     \ j|/k\|  /   \  |/k\|l /
6281 C      \ /   \ /     \ /   \ /
6282 C       o     o       o     o
6283 C       i             i
6284 C
6285 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6286       itk=itortyp(itype(k))
6287       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6288       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6289       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6290       call transpose2(EUgC(1,1,k),auxmat(1,1))
6291       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6292       vv1(1)=pizda1(1,1)-pizda1(2,2)
6293       vv1(2)=pizda1(1,2)+pizda1(2,1)
6294       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6295       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6296       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6297       s5=scalar2(vv(1),Dtobr2(1,i))
6298 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6299       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6300       if (.not. calc_grad) return
6301       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6302      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6303      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6304      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6305      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6306      & +scalar2(vv(1),Dtobr2der(1,i)))
6307       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6308       vv1(1)=pizda1(1,1)-pizda1(2,2)
6309       vv1(2)=pizda1(1,2)+pizda1(2,1)
6310       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6311       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6312       if (l.eq.j+1) then
6313         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6314      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6315      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6316      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6317      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6318       else
6319         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6320      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6321      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6322      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6323      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6324       endif
6325       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6326       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6327       vv1(1)=pizda1(1,1)-pizda1(2,2)
6328       vv1(2)=pizda1(1,2)+pizda1(2,1)
6329       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6330      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6331      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6332      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6333       do iii=1,2
6334         if (swap) then
6335           ind=3-iii
6336         else
6337           ind=iii
6338         endif
6339         do kkk=1,5
6340           do lll=1,3
6341             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6342             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6343             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6344             call transpose2(EUgC(1,1,k),auxmat(1,1))
6345             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6346      &        pizda1(1,1))
6347             vv1(1)=pizda1(1,1)-pizda1(2,2)
6348             vv1(2)=pizda1(1,2)+pizda1(2,1)
6349             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6350             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6351      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6352             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6353      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6354             s5=scalar2(vv(1),Dtobr2(1,i))
6355             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6356           enddo
6357         enddo
6358       enddo
6359       return
6360       end
6361 c----------------------------------------------------------------------------
6362       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6363       implicit real*8 (a-h,o-z)
6364       include 'DIMENSIONS'
6365       include 'sizesclu.dat'
6366       include 'COMMON.IOUNITS'
6367       include 'COMMON.CHAIN'
6368       include 'COMMON.DERIV'
6369       include 'COMMON.INTERACT'
6370       include 'COMMON.CONTACTS'
6371       include 'COMMON.TORSION'
6372       include 'COMMON.VAR'
6373       include 'COMMON.GEO'
6374       logical swap
6375       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6376      & auxvec1(2),auxvec2(1),auxmat1(2,2)
6377       logical lprn
6378       common /kutas/ lprn
6379 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6380 C
6381 C      Parallel       Antiparallel
6382 C
6383 C          o             o
6384 C     \   /l\           /j\   /
6385 C      \ /   \         /   \ /
6386 C       o| o |         | o |o
6387 C     \ j|/k\|      \  |/k\|l
6388 C      \ /   \       \ /   \
6389 C       o             o
6390 C       i             i
6391 C
6392 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6393 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6394 C AL 7/4/01 s1 would occur in the sixth-order moment,
6395 C           but not in a cluster cumulant
6396 #ifdef MOMENT
6397       s1=dip(1,jj,i)*dip(1,kk,k)
6398 #endif
6399       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
6400       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6401       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
6402       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
6403       call transpose2(EUg(1,1,k),auxmat(1,1))
6404       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
6405       vv(1)=pizda(1,1)-pizda(2,2)
6406       vv(2)=pizda(1,2)+pizda(2,1)
6407       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6408 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6409 #ifdef MOMENT
6410       eello6_graph2=-(s1+s2+s3+s4)
6411 #else
6412       eello6_graph2=-(s2+s3+s4)
6413 #endif
6414 c      eello6_graph2=-s3
6415       if (.not. calc_grad) return
6416 C Derivatives in gamma(i-1)
6417       if (i.gt.1) then
6418 #ifdef MOMENT
6419         s1=dipderg(1,jj,i)*dip(1,kk,k)
6420 #endif
6421         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6422         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
6423         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6424         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6425 #ifdef MOMENT
6426         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6427 #else
6428         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6429 #endif
6430 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
6431       endif
6432 C Derivatives in gamma(k-1)
6433 #ifdef MOMENT
6434       s1=dip(1,jj,i)*dipderg(1,kk,k)
6435 #endif
6436       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
6437       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6438       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
6439       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6440       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6441       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
6442       vv(1)=pizda(1,1)-pizda(2,2)
6443       vv(2)=pizda(1,2)+pizda(2,1)
6444       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6445 #ifdef MOMENT
6446       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6447 #else
6448       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6449 #endif
6450 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
6451 C Derivatives in gamma(j-1) or gamma(l-1)
6452       if (j.gt.1) then
6453 #ifdef MOMENT
6454         s1=dipderg(3,jj,i)*dip(1,kk,k)
6455 #endif
6456         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
6457         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6458         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
6459         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
6460         vv(1)=pizda(1,1)-pizda(2,2)
6461         vv(2)=pizda(1,2)+pizda(2,1)
6462         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6463 #ifdef MOMENT
6464         if (swap) then
6465           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6466         else
6467           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6468         endif
6469 #endif
6470         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
6471 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
6472       endif
6473 C Derivatives in gamma(l-1) or gamma(j-1)
6474       if (l.gt.1) then
6475 #ifdef MOMENT
6476         s1=dip(1,jj,i)*dipderg(3,kk,k)
6477 #endif
6478         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
6479         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6480         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
6481         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6482         call matmat2(ADtEA1derg(1,1,2,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(j-1)=g_corr6_loc(j-1)-ekont*s1
6489         else
6490           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6491         endif
6492 #endif
6493         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
6494 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
6495       endif
6496 C Cartesian derivatives.
6497       if (lprn) then
6498         write (2,*) 'In eello6_graph2'
6499         do iii=1,2
6500           write (2,*) 'iii=',iii
6501           do kkk=1,5
6502             write (2,*) 'kkk=',kkk
6503             do jjj=1,2
6504               write (2,'(3(2f10.5),5x)')
6505      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6506             enddo
6507           enddo
6508         enddo
6509       endif
6510       do iii=1,2
6511         do kkk=1,5
6512           do lll=1,3
6513 #ifdef MOMENT
6514             if (iii.eq.1) then
6515               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
6516             else
6517               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
6518             endif
6519 #endif
6520             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
6521      &        auxvec(1))
6522             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6523             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
6524      &        auxvec(1))
6525             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
6526             call transpose2(EUg(1,1,k),auxmat(1,1))
6527             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
6528      &        pizda(1,1))
6529             vv(1)=pizda(1,1)-pizda(2,2)
6530             vv(2)=pizda(1,2)+pizda(2,1)
6531             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6532 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
6533 #ifdef MOMENT
6534             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6535 #else
6536             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6537 #endif
6538             if (swap) then
6539               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6540             else
6541               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6542             endif
6543           enddo
6544         enddo
6545       enddo
6546       return
6547       end
6548 c----------------------------------------------------------------------------
6549       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
6550       implicit real*8 (a-h,o-z)
6551       include 'DIMENSIONS'
6552       include 'sizesclu.dat'
6553       include 'COMMON.IOUNITS'
6554       include 'COMMON.CHAIN'
6555       include 'COMMON.DERIV'
6556       include 'COMMON.INTERACT'
6557       include 'COMMON.CONTACTS'
6558       include 'COMMON.TORSION'
6559       include 'COMMON.VAR'
6560       include 'COMMON.GEO'
6561       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
6562       logical swap
6563 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6564 C
6565 C      Parallel       Antiparallel
6566 C
6567 C          o             o
6568 C         /l\   /   \   /j\
6569 C        /   \ /     \ /   \
6570 C       /| o |o       o| o |\
6571 C       j|/k\|  /      |/k\|l /
6572 C        /   \ /       /   \ /
6573 C       /     o       /     o
6574 C       i             i
6575 C
6576 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6577 C
6578 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6579 C           energy moment and not to the cluster cumulant.
6580       iti=itortyp(itype(i))
6581       if (j.lt.nres-1) then
6582         itj1=itortyp(itype(j+1))
6583       else
6584         itj1=ntortyp+1
6585       endif
6586       itk=itortyp(itype(k))
6587       itk1=itortyp(itype(k+1))
6588       if (l.lt.nres-1) then
6589         itl1=itortyp(itype(l+1))
6590       else
6591         itl1=ntortyp+1
6592       endif
6593 #ifdef MOMENT
6594       s1=dip(4,jj,i)*dip(4,kk,k)
6595 #endif
6596       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
6597       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6598       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
6599       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6600       call transpose2(EE(1,1,itk),auxmat(1,1))
6601       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
6602       vv(1)=pizda(1,1)+pizda(2,2)
6603       vv(2)=pizda(2,1)-pizda(1,2)
6604       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6605 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6606 #ifdef MOMENT
6607       eello6_graph3=-(s1+s2+s3+s4)
6608 #else
6609       eello6_graph3=-(s2+s3+s4)
6610 #endif
6611 c      eello6_graph3=-s4
6612       if (.not. calc_grad) return
6613 C Derivatives in gamma(k-1)
6614       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
6615       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6616       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
6617       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
6618 C Derivatives in gamma(l-1)
6619       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
6620       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6621       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
6622       vv(1)=pizda(1,1)+pizda(2,2)
6623       vv(2)=pizda(2,1)-pizda(1,2)
6624       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6625       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6626 C Cartesian derivatives.
6627       do iii=1,2
6628         do kkk=1,5
6629           do lll=1,3
6630 #ifdef MOMENT
6631             if (iii.eq.1) then
6632               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
6633             else
6634               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
6635             endif
6636 #endif
6637             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6638      &        auxvec(1))
6639             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6640             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6641      &        auxvec(1))
6642             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6643             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
6644      &        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 #ifdef MOMENT
6649             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6650 #else
6651             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6652 #endif
6653             if (swap) then
6654               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6655             else
6656               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6657             endif
6658 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
6659           enddo
6660         enddo
6661       enddo
6662       return
6663       end
6664 c----------------------------------------------------------------------------
6665       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
6666       implicit real*8 (a-h,o-z)
6667       include 'DIMENSIONS'
6668       include 'sizesclu.dat'
6669       include 'COMMON.IOUNITS'
6670       include 'COMMON.CHAIN'
6671       include 'COMMON.DERIV'
6672       include 'COMMON.INTERACT'
6673       include 'COMMON.CONTACTS'
6674       include 'COMMON.TORSION'
6675       include 'COMMON.VAR'
6676       include 'COMMON.GEO'
6677       include 'COMMON.FFIELD'
6678       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6679      & auxvec1(2),auxmat1(2,2)
6680       logical swap
6681 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6682 C
6683 C      Parallel       Antiparallel
6684 C
6685 C          o             o
6686 C         /l\   /   \   /j\
6687 C        /   \ /     \ /   \
6688 C       /| o |o       o| o |\
6689 C     \ j|/k\|      \  |/k\|l
6690 C      \ /   \       \ /   \
6691 C       o     \       o     \
6692 C       i             i
6693 C
6694 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6695 C
6696 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6697 C           energy moment and not to the cluster cumulant.
6698 cd      write (2,*) 'eello_graph4: wturn6',wturn6
6699       iti=itortyp(itype(i))
6700       itj=itortyp(itype(j))
6701       if (j.lt.nres-1) then
6702         itj1=itortyp(itype(j+1))
6703       else
6704         itj1=ntortyp+1
6705       endif
6706       itk=itortyp(itype(k))
6707       if (k.lt.nres-1) then
6708         itk1=itortyp(itype(k+1))
6709       else
6710         itk1=ntortyp+1
6711       endif
6712       itl=itortyp(itype(l))
6713       if (l.lt.nres-1) then
6714         itl1=itortyp(itype(l+1))
6715       else
6716         itl1=ntortyp+1
6717       endif
6718 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
6719 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
6720 cd     & ' itl',itl,' itl1',itl1
6721 #ifdef MOMENT
6722       if (imat.eq.1) then
6723         s1=dip(3,jj,i)*dip(3,kk,k)
6724       else
6725         s1=dip(2,jj,j)*dip(2,kk,l)
6726       endif
6727 #endif
6728       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
6729       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6730       if (j.eq.l+1) then
6731         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
6732         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6733       else
6734         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
6735         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6736       endif
6737       call transpose2(EUg(1,1,k),auxmat(1,1))
6738       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
6739       vv(1)=pizda(1,1)-pizda(2,2)
6740       vv(2)=pizda(2,1)+pizda(1,2)
6741       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6742 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6743 #ifdef MOMENT
6744       eello6_graph4=-(s1+s2+s3+s4)
6745 #else
6746       eello6_graph4=-(s2+s3+s4)
6747 #endif
6748       if (.not. calc_grad) return
6749 C Derivatives in gamma(i-1)
6750       if (i.gt.1) then
6751 #ifdef MOMENT
6752         if (imat.eq.1) then
6753           s1=dipderg(2,jj,i)*dip(3,kk,k)
6754         else
6755           s1=dipderg(4,jj,j)*dip(2,kk,l)
6756         endif
6757 #endif
6758         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6759         if (j.eq.l+1) then
6760           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
6761           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6762         else
6763           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
6764           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6765         endif
6766         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6767         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6768 cd          write (2,*) 'turn6 derivatives'
6769 #ifdef MOMENT
6770           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
6771 #else
6772           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
6773 #endif
6774         else
6775 #ifdef MOMENT
6776           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6777 #else
6778           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6779 #endif
6780         endif
6781       endif
6782 C Derivatives in gamma(k-1)
6783 #ifdef MOMENT
6784       if (imat.eq.1) then
6785         s1=dip(3,jj,i)*dipderg(2,kk,k)
6786       else
6787         s1=dip(2,jj,j)*dipderg(4,kk,l)
6788       endif
6789 #endif
6790       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
6791       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
6792       if (j.eq.l+1) then
6793         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
6794         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6795       else
6796         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
6797         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6798       endif
6799       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6800       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
6801       vv(1)=pizda(1,1)-pizda(2,2)
6802       vv(2)=pizda(2,1)+pizda(1,2)
6803       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6804       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6805 #ifdef MOMENT
6806         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
6807 #else
6808         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
6809 #endif
6810       else
6811 #ifdef MOMENT
6812         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6813 #else
6814         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6815 #endif
6816       endif
6817 C Derivatives in gamma(j-1) or gamma(l-1)
6818       if (l.eq.j+1 .and. l.gt.1) then
6819         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
6820         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6821         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
6822         vv(1)=pizda(1,1)-pizda(2,2)
6823         vv(2)=pizda(2,1)+pizda(1,2)
6824         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6825         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6826       else if (j.gt.1) then
6827         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
6828         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6829         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
6830         vv(1)=pizda(1,1)-pizda(2,2)
6831         vv(2)=pizda(2,1)+pizda(1,2)
6832         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6833         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6834           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
6835         else
6836           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
6837         endif
6838       endif
6839 C Cartesian derivatives.
6840       do iii=1,2
6841         do kkk=1,5
6842           do lll=1,3
6843 #ifdef MOMENT
6844             if (iii.eq.1) then
6845               if (imat.eq.1) then
6846                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
6847               else
6848                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
6849               endif
6850             else
6851               if (imat.eq.1) then
6852                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
6853               else
6854                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
6855               endif
6856             endif
6857 #endif
6858             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
6859      &        auxvec(1))
6860             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6861             if (j.eq.l+1) then
6862               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
6863      &          b1(1,itj1),auxvec(1))
6864               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
6865             else
6866               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
6867      &          b1(1,itl1),auxvec(1))
6868               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
6869             endif
6870             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6871      &        pizda(1,1))
6872             vv(1)=pizda(1,1)-pizda(2,2)
6873             vv(2)=pizda(2,1)+pizda(1,2)
6874             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6875             if (swap) then
6876               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6877 #ifdef MOMENT
6878                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
6879      &             -(s1+s2+s4)
6880 #else
6881                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
6882      &             -(s2+s4)
6883 #endif
6884                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
6885               else
6886 #ifdef MOMENT
6887                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
6888 #else
6889                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
6890 #endif
6891                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6892               endif
6893             else
6894 #ifdef MOMENT
6895               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6896 #else
6897               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6898 #endif
6899               if (l.eq.j+1) then
6900                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6901               else
6902                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6903               endif
6904             endif
6905           enddo
6906         enddo
6907       enddo
6908       return
6909       end
6910 c----------------------------------------------------------------------------
6911       double precision function eello_turn6(i,jj,kk)
6912       implicit real*8 (a-h,o-z)
6913       include 'DIMENSIONS'
6914       include 'sizesclu.dat'
6915       include 'COMMON.IOUNITS'
6916       include 'COMMON.CHAIN'
6917       include 'COMMON.DERIV'
6918       include 'COMMON.INTERACT'
6919       include 'COMMON.CONTACTS'
6920       include 'COMMON.TORSION'
6921       include 'COMMON.VAR'
6922       include 'COMMON.GEO'
6923       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
6924      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
6925      &  ggg1(3),ggg2(3)
6926       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
6927      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
6928 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
6929 C           the respective energy moment and not to the cluster cumulant.
6930       eello_turn6=0.0d0
6931       j=i+4
6932       k=i+1
6933       l=i+3
6934       iti=itortyp(itype(i))
6935       itk=itortyp(itype(k))
6936       itk1=itortyp(itype(k+1))
6937       itl=itortyp(itype(l))
6938       itj=itortyp(itype(j))
6939 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
6940 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
6941 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6942 cd        eello6=0.0d0
6943 cd        return
6944 cd      endif
6945 cd      write (iout,*)
6946 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6947 cd     &   ' and',k,l
6948 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
6949       do iii=1,2
6950         do kkk=1,5
6951           do lll=1,3
6952             derx_turn(lll,kkk,iii)=0.0d0
6953           enddo
6954         enddo
6955       enddo
6956 cd      eij=1.0d0
6957 cd      ekl=1.0d0
6958 cd      ekont=1.0d0
6959       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6960 cd      eello6_5=0.0d0
6961 cd      write (2,*) 'eello6_5',eello6_5
6962 #ifdef MOMENT
6963       call transpose2(AEA(1,1,1),auxmat(1,1))
6964       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
6965       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
6966       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
6967 #else
6968       s1 = 0.0d0
6969 #endif
6970       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
6971       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
6972       s2 = scalar2(b1(1,itk),vtemp1(1))
6973 #ifdef MOMENT
6974       call transpose2(AEA(1,1,2),atemp(1,1))
6975       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
6976       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
6977       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
6978 #else
6979       s8=0.0d0
6980 #endif
6981       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
6982       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
6983       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
6984 #ifdef MOMENT
6985       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
6986       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
6987       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
6988       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
6989       ss13 = scalar2(b1(1,itk),vtemp4(1))
6990       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
6991 #else
6992       s13=0.0d0
6993 #endif
6994 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
6995 c      s1=0.0d0
6996 c      s2=0.0d0
6997 c      s8=0.0d0
6998 c      s12=0.0d0
6999 c      s13=0.0d0
7000       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7001       if (calc_grad) then
7002 C Derivatives in gamma(i+2)
7003 #ifdef MOMENT
7004       call transpose2(AEA(1,1,1),auxmatd(1,1))
7005       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7006       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7007       call transpose2(AEAderg(1,1,2),atempd(1,1))
7008       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7009       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7010 #else
7011       s8d=0.0d0
7012 #endif
7013       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7014       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7015       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7016 c      s1d=0.0d0
7017 c      s2d=0.0d0
7018 c      s8d=0.0d0
7019 c      s12d=0.0d0
7020 c      s13d=0.0d0
7021       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7022 C Derivatives in gamma(i+3)
7023 #ifdef MOMENT
7024       call transpose2(AEA(1,1,1),auxmatd(1,1))
7025       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7026       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7027       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7028 #else
7029       s1d=0.0d0
7030 #endif
7031       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7032       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7033       s2d = scalar2(b1(1,itk),vtemp1d(1))
7034 #ifdef MOMENT
7035       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7036       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7037 #endif
7038       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7039 #ifdef MOMENT
7040       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7041       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7042       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7043 #else
7044       s13d=0.0d0
7045 #endif
7046 c      s1d=0.0d0
7047 c      s2d=0.0d0
7048 c      s8d=0.0d0
7049 c      s12d=0.0d0
7050 c      s13d=0.0d0
7051 #ifdef MOMENT
7052       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7053      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7054 #else
7055       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7056      &               -0.5d0*ekont*(s2d+s12d)
7057 #endif
7058 C Derivatives in gamma(i+4)
7059       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7060       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7061       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7062 #ifdef MOMENT
7063       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7064       call matmat2(gtempd(1,1),EUgder(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+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7076 #else
7077       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7078 #endif
7079 C Derivatives in gamma(i+5)
7080 #ifdef MOMENT
7081       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7082       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7083       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7084 #else
7085       s1d = 0.0d0
7086 #endif
7087       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7088       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7089       s2d = scalar2(b1(1,itk),vtemp1d(1))
7090 #ifdef MOMENT
7091       call transpose2(AEA(1,1,2),atempd(1,1))
7092       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7093       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7094 #else
7095       s8d = 0.0d0
7096 #endif
7097       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7098       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7099 #ifdef MOMENT
7100       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7101       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7102       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7103 #else
7104       s13d = 0.0d0
7105 #endif
7106 c      s1d=0.0d0
7107 c      s2d=0.0d0
7108 c      s8d=0.0d0
7109 c      s12d=0.0d0
7110 c      s13d=0.0d0
7111 #ifdef MOMENT
7112       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7113      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7114 #else
7115       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7116      &               -0.5d0*ekont*(s2d+s12d)
7117 #endif
7118 C Cartesian derivatives
7119       do iii=1,2
7120         do kkk=1,5
7121           do lll=1,3
7122 #ifdef MOMENT
7123             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7124             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7125             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7126 #else
7127             s1d = 0.0d0
7128 #endif
7129             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7130             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7131      &          vtemp1d(1))
7132             s2d = scalar2(b1(1,itk),vtemp1d(1))
7133 #ifdef MOMENT
7134             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7135             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7136             s8d = -(atempd(1,1)+atempd(2,2))*
7137      &           scalar2(cc(1,1,itl),vtemp2(1))
7138 #else
7139             s8d = 0.0d0
7140 #endif
7141             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7142      &           auxmatd(1,1))
7143             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7144             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7145 c      s1d=0.0d0
7146 c      s2d=0.0d0
7147 c      s8d=0.0d0
7148 c      s12d=0.0d0
7149 c      s13d=0.0d0
7150 #ifdef MOMENT
7151             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7152      &        - 0.5d0*(s1d+s2d)
7153 #else
7154             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7155      &        - 0.5d0*s2d
7156 #endif
7157 #ifdef MOMENT
7158             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7159      &        - 0.5d0*(s8d+s12d)
7160 #else
7161             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7162      &        - 0.5d0*s12d
7163 #endif
7164           enddo
7165         enddo
7166       enddo
7167 #ifdef MOMENT
7168       do kkk=1,5
7169         do lll=1,3
7170           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7171      &      achuj_tempd(1,1))
7172           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7173           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7174           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7175           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7176           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7177      &      vtemp4d(1))
7178           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7179           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7180           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7181         enddo
7182       enddo
7183 #endif
7184 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7185 cd     &  16*eel_turn6_num
7186 cd      goto 1112
7187       if (j.lt.nres-1) then
7188         j1=j+1
7189         j2=j-1
7190       else
7191         j1=j-1
7192         j2=j-2
7193       endif
7194       if (l.lt.nres-1) then
7195         l1=l+1
7196         l2=l-1
7197       else
7198         l1=l-1
7199         l2=l-2
7200       endif
7201       do ll=1,3
7202         ggg1(ll)=eel_turn6*g_contij(ll,1)
7203         ggg2(ll)=eel_turn6*g_contij(ll,2)
7204         ghalf=0.5d0*ggg1(ll)
7205 cd        ghalf=0.0d0
7206         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7207      &    +ekont*derx_turn(ll,2,1)
7208         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7209         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7210      &    +ekont*derx_turn(ll,4,1)
7211         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7212         ghalf=0.5d0*ggg2(ll)
7213 cd        ghalf=0.0d0
7214         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7215      &    +ekont*derx_turn(ll,2,2)
7216         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7217         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7218      &    +ekont*derx_turn(ll,4,2)
7219         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7220       enddo
7221 cd      goto 1112
7222       do m=i+1,j-1
7223         do ll=1,3
7224           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7225         enddo
7226       enddo
7227       do m=k+1,l-1
7228         do ll=1,3
7229           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7230         enddo
7231       enddo
7232 1112  continue
7233       do m=i+2,j2
7234         do ll=1,3
7235           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7236         enddo
7237       enddo
7238       do m=k+2,l2
7239         do ll=1,3
7240           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7241         enddo
7242       enddo
7243 cd      do iii=1,nres-3
7244 cd        write (2,*) iii,g_corr6_loc(iii)
7245 cd      enddo
7246       endif
7247       eello_turn6=ekont*eel_turn6
7248 cd      write (2,*) 'ekont',ekont
7249 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7250       return
7251       end
7252 crc-------------------------------------------------
7253       SUBROUTINE MATVEC2(A1,V1,V2)
7254       implicit real*8 (a-h,o-z)
7255       include 'DIMENSIONS'
7256       DIMENSION A1(2,2),V1(2),V2(2)
7257 c      DO 1 I=1,2
7258 c        VI=0.0
7259 c        DO 3 K=1,2
7260 c    3     VI=VI+A1(I,K)*V1(K)
7261 c        Vaux(I)=VI
7262 c    1 CONTINUE
7263
7264       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7265       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7266
7267       v2(1)=vaux1
7268       v2(2)=vaux2
7269       END
7270 C---------------------------------------
7271       SUBROUTINE MATMAT2(A1,A2,A3)
7272       implicit real*8 (a-h,o-z)
7273       include 'DIMENSIONS'
7274       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7275 c      DIMENSION AI3(2,2)
7276 c        DO  J=1,2
7277 c          A3IJ=0.0
7278 c          DO K=1,2
7279 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7280 c          enddo
7281 c          A3(I,J)=A3IJ
7282 c       enddo
7283 c      enddo
7284
7285       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7286       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7287       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7288       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7289
7290       A3(1,1)=AI3_11
7291       A3(2,1)=AI3_21
7292       A3(1,2)=AI3_12
7293       A3(2,2)=AI3_22
7294       END
7295
7296 c-------------------------------------------------------------------------
7297       double precision function scalar2(u,v)
7298       implicit none
7299       double precision u(2),v(2)
7300       double precision sc
7301       integer i
7302       scalar2=u(1)*v(1)+u(2)*v(2)
7303       return
7304       end
7305
7306 C-----------------------------------------------------------------------------
7307
7308       subroutine transpose2(a,at)
7309       implicit none
7310       double precision a(2,2),at(2,2)
7311       at(1,1)=a(1,1)
7312       at(1,2)=a(2,1)
7313       at(2,1)=a(1,2)
7314       at(2,2)=a(2,2)
7315       return
7316       end
7317 c--------------------------------------------------------------------------
7318       subroutine transpose(n,a,at)
7319       implicit none
7320       integer n,i,j
7321       double precision a(n,n),at(n,n)
7322       do i=1,n
7323         do j=1,n
7324           at(j,i)=a(i,j)
7325         enddo
7326       enddo
7327       return
7328       end
7329 C---------------------------------------------------------------------------
7330       subroutine prodmat3(a1,a2,kk,transp,prod)
7331       implicit none
7332       integer i,j
7333       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
7334       logical transp
7335 crc      double precision auxmat(2,2),prod_(2,2)
7336
7337       if (transp) then
7338 crc        call transpose2(kk(1,1),auxmat(1,1))
7339 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
7340 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7341
7342            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
7343      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
7344            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
7345      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
7346            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
7347      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
7348            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
7349      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
7350
7351       else
7352 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
7353 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7354
7355            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
7356      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
7357            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
7358      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
7359            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
7360      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
7361            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
7362      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
7363
7364       endif
7365 c      call transpose2(a2(1,1),a2t(1,1))
7366
7367 crc      print *,transp
7368 crc      print *,((prod_(i,j),i=1,2),j=1,2)
7369 crc      print *,((prod(i,j),i=1,2),j=1,2)
7370
7371       return
7372       end
7373 C-----------------------------------------------------------------------------
7374       double precision function scalar(u,v)
7375       implicit none
7376       double precision u(3),v(3)
7377       double precision sc
7378       integer i
7379       sc=0.0d0
7380       do i=1,3
7381         sc=sc+u(i)*v(i)
7382       enddo
7383       scalar=sc
7384       return
7385       end
7386