source/wham/src-M/energy_p_new.F

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