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