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