source/wham/src-M/energy_p_new.F

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