source/wham/src-M/energy_p_new.F

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