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