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