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