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