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