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