source/wham/src-M-NEWCORR/energy_p_new.F

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