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