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