source/wham/src-M/energy_p_new.F

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