source/wham/src/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+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+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      if (dyn_ss) call dyn_set_nss
 158 c detecting NaNQ
 159 #ifdef ISNAN
 160 #ifdef AIX
 161       if (isnan(etot).ne.0) energia(0)=1.0d+99
 162 #else
 163       if (isnan(etot)) energia(0)=1.0d+99
 164 #endif
 165 #else
 166       i=0
 167 #ifdef WINPGI
 168       idumm=proc_proc(etot,i)
 169 #else
 170       call proc_proc(etot,i)
 171 #endif
 172       if(i.eq.1)energia(0)=1.0d+99
 173 #endif
 174 #ifdef MPL
 175 c     endif
 176 #endif
 177       if (calc_grad) then
 178 C
 179 C Sum up the components of the Cartesian gradient.
 180 C
 181 #ifdef SPLITELE
 182       do i=1,nct
 183         do j=1,3
 184           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 185      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 186      &                wbond*gradb(j,i)+
 187      &                wstrain*ghpbc(j,i)+
 188      &                wcorr*fact(3)*gradcorr(j,i)+
 189      &                wel_loc*fact(2)*gel_loc(j,i)+
 190      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 191      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 192      &                wcorr5*fact(4)*gradcorr5(j,i)+
 193      &                wcorr6*fact(5)*gradcorr6(j,i)+
 194      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 195      &                wsccor*fact(2)*gsccorc(j,i)
 196           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 197      &                  wbond*gradbx(j,i)+
 198      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 199      &                  wsccor*fact(2)*gsccorx(j,i)
 200         enddo
 201 #else
 202       do i=1,nct
 203         do j=1,3
 204           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 205      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 206      &                wbond*gradb(j,i)+
 207      &                wcorr*fact(3)*gradcorr(j,i)+
 208      &                wel_loc*fact(2)*gel_loc(j,i)+
 209      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 210      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 211      &                wcorr5*fact(4)*gradcorr5(j,i)+
 212      &                wcorr6*fact(5)*gradcorr6(j,i)+
 213      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 214      &                wsccor*fact(2)*gsccorc(j,i)
 215           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 216      &                  wbond*gradbx(j,i)+
 217      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 218      &                  wsccor*fact(1)*gsccorx(j,i)
 219         enddo
 220 #endif
 221       enddo
 222
 223
 224       do i=1,nres-3
 225         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 226      &   +wcorr5*fact(4)*g_corr5_loc(i)
 227      &   +wcorr6*fact(5)*g_corr6_loc(i)
 228      &   +wturn4*fact(3)*gel_loc_turn4(i)
 229      &   +wturn3*fact(2)*gel_loc_turn3(i)
 230      &   +wturn6*fact(5)*gel_loc_turn6(i)
 231      &   +wel_loc*fact(2)*gel_loc_loc(i)
 232      &   +wsccor*fact(1)*gsccor_loc(i)
 233       enddo
 234       endif
 235       return
 236       end
 237 C------------------------------------------------------------------------
 238       subroutine enerprint(energia,fact)
 239       implicit real*8 (a-h,o-z)
 240       include 'DIMENSIONS'
 241       include 'DIMENSIONS.ZSCOPT'
 242       include 'COMMON.IOUNITS'
 243       include 'COMMON.FFIELD'
 244       include 'COMMON.SBRIDGE'
 245       double precision energia(0:max_ene),fact(6)
 246       etot=energia(0)
 247       evdw=energia(1)+fact(6)*energia(21)
 248 #ifdef SCP14
 249       evdw2=energia(2)+energia(17)
 250 #else
 251       evdw2=energia(2)
 252 #endif
 253       ees=energia(3)
 254 #ifdef SPLITELE
 255       evdw1=energia(16)
 256 #endif
 257       ecorr=energia(4)
 258       ecorr5=energia(5)
 259       ecorr6=energia(6)
 260       eel_loc=energia(7)
 261       eello_turn3=energia(8)
 262       eello_turn4=energia(9)
 263       eello_turn6=energia(10)
 264       ebe=energia(11)
 265       escloc=energia(12)
 266       etors=energia(13)
 267       etors_d=energia(14)
 268       ehpb=energia(15)
 269       esccor=energia(19)
 270       edihcnstr=energia(20)
 271       estr=energia(18)
 272 #ifdef SPLITELE
 273       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 274      &  wvdwpp,
 275      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 276      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 277      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 278      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 279      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 280      &  esccor,wsccor*fact(1),edihcnstr,ebr*nss,etot
 281    10 format (/'Virtual-chain energies:'//
 282      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 283      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 284      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 285      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 286      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 287      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 288      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 289      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 290      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 291      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 292      & ' (SS bridges & dist. cnstr.)'/
 293      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 294      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 295      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 296      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 297      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 298      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 299      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 300      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 301      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 302      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 303      & 'ETOT=  ',1pE16.6,' (total)')
 304 #else
 305       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 306      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 307      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 308      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 309      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 310      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 311      &  edihcnstr,ebr*nss,etot
 312    10 format (/'Virtual-chain energies:'//
 313      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 314      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 315      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 316      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 317      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 318      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 319      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 320      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 321      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 322      & ' (SS bridges & dist. cnstr.)'/
 323      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 324      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 325      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 326      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 327      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 328      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 329      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 330      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 331      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 332      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 333      & 'ETOT=  ',1pE16.6,' (total)')
 334 #endif
 335       return
 336       end
 337 C-----------------------------------------------------------------------
 338       subroutine elj(evdw,evdw_t)
 339 C
 340 C This subroutine calculates the interaction energy of nonbonded side chains
 341 C assuming the LJ potential of interaction.
 342 C
 343       implicit real*8 (a-h,o-z)
 344       include 'DIMENSIONS'
 345       include 'DIMENSIONS.ZSCOPT'
 346       include "DIMENSIONS.COMPAR"
 347       parameter (accur=1.0d-10)
 348       include 'COMMON.GEO'
 349       include 'COMMON.VAR'
 350       include 'COMMON.LOCAL'
 351       include 'COMMON.CHAIN'
 352       include 'COMMON.DERIV'
 353       include 'COMMON.INTERACT'
 354       include 'COMMON.TORSION'
 355       include 'COMMON.ENEPS'
 356       include 'COMMON.SBRIDGE'
 357       include 'COMMON.NAMES'
 358       include 'COMMON.IOUNITS'
 359       include 'COMMON.CONTACTS'
 360       dimension gg(3)
 361       integer icant
 362       external icant
 363 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 364       do i=1,210
 365         do j=1,2
 366           eneps_temp(j,i)=0.0d0
 367         enddo
 368       enddo
 369       evdw=0.0D0
 370       evdw_t=0.0d0
 371       do i=iatsc_s,iatsc_e
 372         itypi=itype(i)
 373         itypi1=itype(i+1)
 374         xi=c(1,nres+i)
 375         yi=c(2,nres+i)
 376         zi=c(3,nres+i)
 377 C Change 12/1/95
 378         num_conti=0
 379 C
 380 C Calculate SC interaction energy.
 381 C
 382         do iint=1,nint_gr(i)
 383 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 384 cd   &                  'iend=',iend(i,iint)
 385           do j=istart(i,iint),iend(i,iint)
 386             itypj=itype(j)
 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=itype(i)
 544         itypi1=itype(i+1)
 545         xi=c(1,nres+i)
 546         yi=c(2,nres+i)
 547         zi=c(3,nres+i)
 548 C
 549 C Calculate SC interaction energy.
 550 C
 551         do iint=1,nint_gr(i)
 552           do j=istart(i,iint),iend(i,iint)
 553             itypj=itype(j)
 554             xj=c(1,nres+j)-xi
 555             yj=c(2,nres+j)-yi
 556             zj=c(3,nres+j)-zi
 557             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 558             fac_augm=rrij**expon
 559             e_augm=augm(itypi,itypj)*fac_augm
 560             r_inv_ij=dsqrt(rrij)
 561             rij=1.0D0/r_inv_ij
 562             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 563             fac=r_shift_inv**expon
 564             e1=fac*fac*aa(itypi,itypj)
 565             e2=fac*bb(itypi,itypj)
 566             evdwij=e_augm+e1+e2
 567             ij=icant(itypi,itypj)
 568             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 569      &        /dabs(eps(itypi,itypj))
 570             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 571 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 572 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 573 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 574 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 575 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 576 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 577 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 578             if (bb(itypi,itypj).gt.0.0d0) then
 579               evdw=evdw+evdwij
 580             else
 581               evdw_t=evdw_t+evdwij
 582             endif
 583             if (calc_grad) then
 584 C
 585 C Calculate the components of the gradient in DC and X
 586 C
 587             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 588             gg(1)=xj*fac
 589             gg(2)=yj*fac
 590             gg(3)=zj*fac
 591             do k=1,3
 592               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 593               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 594             enddo
 595             do k=i,j-1
 596               do l=1,3
 597                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 598               enddo
 599             enddo
 600             endif
 601           enddo      ! j
 602         enddo        ! iint
 603       enddo          ! i
 604       if (calc_grad) then
 605       do i=1,nct
 606         do j=1,3
 607           gvdwc(j,i)=expon*gvdwc(j,i)
 608           gvdwx(j,i)=expon*gvdwx(j,i)
 609         enddo
 610       enddo
 611       endif
 612       return
 613       end
 614 C-----------------------------------------------------------------------------
 615       subroutine ebp(evdw,evdw_t)
 616 C
 617 C This subroutine calculates the interaction energy of nonbonded side chains
 618 C assuming the Berne-Pechukas potential of interaction.
 619 C
 620       implicit real*8 (a-h,o-z)
 621       include 'DIMENSIONS'
 622       include 'DIMENSIONS.ZSCOPT'
 623       include "DIMENSIONS.COMPAR"
 624       include 'COMMON.GEO'
 625       include 'COMMON.VAR'
 626       include 'COMMON.LOCAL'
 627       include 'COMMON.CHAIN'
 628       include 'COMMON.DERIV'
 629       include 'COMMON.NAMES'
 630       include 'COMMON.INTERACT'
 631       include 'COMMON.ENEPS'
 632       include 'COMMON.IOUNITS'
 633       include 'COMMON.CALC'
 634       common /srutu/ icall
 635 c     double precision rrsave(maxdim)
 636       logical lprn
 637       integer icant
 638       external icant
 639       do i=1,210
 640         do j=1,2
 641           eneps_temp(j,i)=0.0d0
 642         enddo
 643       enddo
 644       evdw=0.0D0
 645       evdw_t=0.0d0
 646 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 647 c     if (icall.eq.0) then
 648 c       lprn=.true.
 649 c     else
 650         lprn=.false.
 651 c     endif
 652       ind=0
 653       do i=iatsc_s,iatsc_e
 654         itypi=itype(i)
 655         itypi1=itype(i+1)
 656         xi=c(1,nres+i)
 657         yi=c(2,nres+i)
 658         zi=c(3,nres+i)
 659         dxi=dc_norm(1,nres+i)
 660         dyi=dc_norm(2,nres+i)
 661         dzi=dc_norm(3,nres+i)
 662         dsci_inv=vbld_inv(i+nres)
 663 C
 664 C Calculate SC interaction energy.
 665 C
 666         do iint=1,nint_gr(i)
 667           do j=istart(i,iint),iend(i,iint)
 668             ind=ind+1
 669             itypj=itype(j)
 670             dscj_inv=vbld_inv(j+nres)
 671             chi1=chi(itypi,itypj)
 672             chi2=chi(itypj,itypi)
 673             chi12=chi1*chi2
 674             chip1=chip(itypi)
 675             chip2=chip(itypj)
 676             chip12=chip1*chip2
 677             alf1=alp(itypi)
 678             alf2=alp(itypj)
 679             alf12=0.5D0*(alf1+alf2)
 680 C For diagnostics only!!!
 681 c           chi1=0.0D0
 682 c           chi2=0.0D0
 683 c           chi12=0.0D0
 684 c           chip1=0.0D0
 685 c           chip2=0.0D0
 686 c           chip12=0.0D0
 687 c           alf1=0.0D0
 688 c           alf2=0.0D0
 689 c           alf12=0.0D0
 690             xj=c(1,nres+j)-xi
 691             yj=c(2,nres+j)-yi
 692             zj=c(3,nres+j)-zi
 693             dxj=dc_norm(1,nres+j)
 694             dyj=dc_norm(2,nres+j)
 695             dzj=dc_norm(3,nres+j)
 696             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 697 cd          if (icall.eq.0) then
 698 cd            rrsave(ind)=rrij
 699 cd          else
 700 cd            rrij=rrsave(ind)
 701 cd          endif
 702             rij=dsqrt(rrij)
 703 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 704             call sc_angular
 705 C Calculate whole angle-dependent part of epsilon and contributions
 706 C to its derivatives
 707             fac=(rrij*sigsq)**expon2
 708             e1=fac*fac*aa(itypi,itypj)
 709             e2=fac*bb(itypi,itypj)
 710             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 711             eps2der=evdwij*eps3rt
 712             eps3der=evdwij*eps2rt
 713             evdwij=evdwij*eps2rt*eps3rt
 714             ij=icant(itypi,itypj)
 715             aux=eps1*eps2rt**2*eps3rt**2
 716             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 717      &        /dabs(eps(itypi,itypj))
 718             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 719             if (bb(itypi,itypj).gt.0.0d0) then
 720               evdw=evdw+evdwij
 721             else
 722               evdw_t=evdw_t+evdwij
 723             endif
 724             if (calc_grad) then
 725             if (lprn) then
 726             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 727             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 728 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 729 cd     &        restyp(itypi),i,restyp(itypj),j,
 730 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 731 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 732 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 733 cd     &        evdwij
 734             endif
 735 C Calculate gradient components.
 736             e1=e1*eps1*eps2rt**2*eps3rt**2
 737             fac=-expon*(e1+evdwij)
 738             sigder=fac/sigsq
 739             fac=rrij*fac
 740 C Calculate radial part of the gradient
 741             gg(1)=xj*fac
 742             gg(2)=yj*fac
 743             gg(3)=zj*fac
 744 C Calculate the angular part of the gradient and sum add the contributions
 745 C to the appropriate components of the Cartesian gradient.
 746             call sc_grad
 747             endif
 748           enddo      ! j
 749         enddo        ! iint
 750       enddo          ! i
 751 c     stop
 752       return
 753       end
 754 C-----------------------------------------------------------------------------
 755       subroutine egb(evdw,evdw_t)
 756 C
 757 C This subroutine calculates the interaction energy of nonbonded side chains
 758 C assuming the Gay-Berne potential of interaction.
 759 C
 760       implicit real*8 (a-h,o-z)
 761       include 'DIMENSIONS'
 762       include 'DIMENSIONS.ZSCOPT'
 763       include "DIMENSIONS.COMPAR"
 764       include 'COMMON.GEO'
 765       include 'COMMON.VAR'
 766       include 'COMMON.LOCAL'
 767       include 'COMMON.CHAIN'
 768       include 'COMMON.DERIV'
 769       include 'COMMON.NAMES'
 770       include 'COMMON.INTERACT'
 771       include 'COMMON.ENEPS'
 772       include 'COMMON.IOUNITS'
 773       include 'COMMON.CALC'
 774       include 'COMMON.SBRIDGE'
 775       logical lprn
 776       common /srutu/icall
 777       integer icant
 778       external icant
 779       do i=1,210
 780         do j=1,2
 781           eneps_temp(j,i)=0.0d0
 782         enddo
 783       enddo
 784 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 785       evdw=0.0D0
 786       evdw_t=0.0d0
 787       lprn=.false.
 788 c      if (icall.gt.0) lprn=.true.
 789       ind=0
 790       do i=iatsc_s,iatsc_e
 791         itypi=itype(i)
 792         itypi1=itype(i+1)
 793         xi=c(1,nres+i)
 794         yi=c(2,nres+i)
 795         zi=c(3,nres+i)
 796         dxi=dc_norm(1,nres+i)
 797         dyi=dc_norm(2,nres+i)
 798         dzi=dc_norm(3,nres+i)
 799         dsci_inv=vbld_inv(i+nres)
 800 C
 801 C Calculate SC interaction energy.
 802 C
 803         do iint=1,nint_gr(i)
 804           do j=istart(i,iint),iend(i,iint)
 805 C in case of diagnostics    write (iout,*) "TU SZUKAJ",i,j,dyn_ss_mask(i),dyn_ss_mask(j)
 806 C /06/28/2013 Adasko: In case of dyn_ss - dynamic disulfide bond
 807 C formation no electrostatic interactions should be calculated. If it
 808 C would be allowed NaN would appear
 809             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 810 C /06/28/2013 Adasko: dyn_ss_mask is logical statement wheather this Cys
 811 C residue can or cannot form disulfide bond. There is still bug allowing
 812 C Cys...Cys...Cys bond formation
 813               call dyn_ssbond_ene(i,j,evdwij)
 814 C /06/28/2013 Adasko: dyn_ssbond_ene is dynamic SS bond foration energy
 815 C function in ssMD.F
 816               evdw=evdw+evdwij
 817 c              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 818 c     &                        'evdw',i,j,evdwij,' ss'
 819             ELSE
 820             ind=ind+1
 821             itypj=itype(j)
 822             dscj_inv=vbld_inv(j+nres)
 823             sig0ij=sigma(itypi,itypj)
 824             chi1=chi(itypi,itypj)
 825             chi2=chi(itypj,itypi)
 826             chi12=chi1*chi2
 827             chip1=chip(itypi)
 828             chip2=chip(itypj)
 829             chip12=chip1*chip2
 830             alf1=alp(itypi)
 831             alf2=alp(itypj)
 832             alf12=0.5D0*(alf1+alf2)
 833 C For diagnostics only!!!
 834 c           chi1=0.0D0
 835 c           chi2=0.0D0
 836 c           chi12=0.0D0
 837 c           chip1=0.0D0
 838 c           chip2=0.0D0
 839 c           chip12=0.0D0
 840 c           alf1=0.0D0
 841 c           alf2=0.0D0
 842 c           alf12=0.0D0
 843             xj=c(1,nres+j)-xi
 844             yj=c(2,nres+j)-yi
 845             zj=c(3,nres+j)-zi
 846             dxj=dc_norm(1,nres+j)
 847             dyj=dc_norm(2,nres+j)
 848             dzj=dc_norm(3,nres+j)
 849 c            write (iout,*) i,j,xj,yj,zj
 850             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 851             rij=dsqrt(rrij)
 852 C Calculate angle-dependent terms of energy and contributions to their
 853 C derivatives.
 854             call sc_angular
 855             sigsq=1.0D0/sigsq
 856             sig=sig0ij*dsqrt(sigsq)
 857             rij_shift=1.0D0/rij-sig+sig0ij
 858 C I hate to put IF's in the loops, but here don't have another choice!!!!
 859             if (rij_shift.le.0.0D0) then
 860               evdw=1.0D20
 861               return
 862             endif
 863             sigder=-sig*sigsq
 864 c---------------------------------------------------------------
 865             rij_shift=1.0D0/rij_shift
 866             fac=rij_shift**expon
 867             e1=fac*fac*aa(itypi,itypj)
 868             e2=fac*bb(itypi,itypj)
 869             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 870             eps2der=evdwij*eps3rt
 871             eps3der=evdwij*eps2rt
 872             evdwij=evdwij*eps2rt*eps3rt
 873             if (bb(itypi,itypj).gt.0) then
 874               evdw=evdw+evdwij
 875             else
 876               evdw_t=evdw_t+evdwij
 877             endif
 878             ij=icant(itypi,itypj)
 879             aux=eps1*eps2rt**2*eps3rt**2
 880             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
 881      &        /dabs(eps(itypi,itypj))
 882             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
 883 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
 884 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
 885 c     &         aux*e2/eps(itypi,itypj)
 886 c       write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
 887             if (lprn) then
 888             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 889             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 890             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
 891      &        restyp(itypi),i,restyp(itypj),j,
 892      &        epsi,sigm,chi1,chi2,chip1,chip2,
 893      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
 894      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
 895      &        evdwij
 896             endif
 897             if (calc_grad) then
 898 C Calculate gradient components.
 899             e1=e1*eps1*eps2rt**2*eps3rt**2
 900             fac=-expon*(e1+evdwij)*rij_shift
 901             sigder=fac*sigder
 902             fac=rij*fac
 903 C Calculate the radial part of the gradient
 904             gg(1)=xj*fac
 905             gg(2)=yj*fac
 906             gg(3)=zj*fac
 907 C Calculate angular part of the gradient.
 908             call sc_grad
 909             endif
 910             ENDIF    ! dyn_ss
 911           enddo      ! j
 912         enddo        ! iint
 913       enddo          ! i
 914       return
 915       end
 916 C-----------------------------------------------------------------------------
 917       subroutine egbv(evdw,evdw_t)
 918 C
 919 C This subroutine calculates the interaction energy of nonbonded side chains
 920 C assuming the Gay-Berne-Vorobjev potential of interaction.
 921 C
 922       implicit real*8 (a-h,o-z)
 923       include 'DIMENSIONS'
 924       include 'DIMENSIONS.ZSCOPT'
 925       include "DIMENSIONS.COMPAR"
 926       include 'COMMON.GEO'
 927       include 'COMMON.VAR'
 928       include 'COMMON.LOCAL'
 929       include 'COMMON.CHAIN'
 930       include 'COMMON.DERIV'
 931       include 'COMMON.NAMES'
 932       include 'COMMON.INTERACT'
 933       include 'COMMON.ENEPS'
 934       include 'COMMON.IOUNITS'
 935       include 'COMMON.CALC'
 936       common /srutu/ icall
 937       logical lprn
 938       integer icant
 939       external icant
 940       do i=1,210
 941         do j=1,2
 942           eneps_temp(j,i)=0.0d0
 943         enddo
 944       enddo
 945       evdw=0.0D0
 946       evdw_t=0.0d0
 947 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 948       evdw=0.0D0
 949       lprn=.false.
 950 c      if (icall.gt.0) lprn=.true.
 951       ind=0
 952       do i=iatsc_s,iatsc_e
 953         itypi=itype(i)
 954         itypi1=itype(i+1)
 955         xi=c(1,nres+i)
 956         yi=c(2,nres+i)
 957         zi=c(3,nres+i)
 958         dxi=dc_norm(1,nres+i)
 959         dyi=dc_norm(2,nres+i)
 960         dzi=dc_norm(3,nres+i)
 961         dsci_inv=vbld_inv(i+nres)
 962 C
 963 C Calculate SC interaction energy.
 964 C
 965         do iint=1,nint_gr(i)
 966           do j=istart(i,iint),iend(i,iint)
 967             ind=ind+1
 968             itypj=itype(j)
 969             dscj_inv=vbld_inv(j+nres)
 970             sig0ij=sigma(itypi,itypj)
 971             r0ij=r0(itypi,itypj)
 972             chi1=chi(itypi,itypj)
 973             chi2=chi(itypj,itypi)
 974             chi12=chi1*chi2
 975             chip1=chip(itypi)
 976             chip2=chip(itypj)
 977             chip12=chip1*chip2
 978             alf1=alp(itypi)
 979             alf2=alp(itypj)
 980             alf12=0.5D0*(alf1+alf2)
 981 C For diagnostics only!!!
 982 c           chi1=0.0D0
 983 c           chi2=0.0D0
 984 c           chi12=0.0D0
 985 c           chip1=0.0D0
 986 c           chip2=0.0D0
 987 c           chip12=0.0D0
 988 c           alf1=0.0D0
 989 c           alf2=0.0D0
 990 c           alf12=0.0D0
 991             xj=c(1,nres+j)-xi
 992             yj=c(2,nres+j)-yi
 993             zj=c(3,nres+j)-zi
 994             dxj=dc_norm(1,nres+j)
 995             dyj=dc_norm(2,nres+j)
 996             dzj=dc_norm(3,nres+j)
 997             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 998             rij=dsqrt(rrij)
 999 C Calculate angle-dependent terms of energy and contributions to their
1000 C derivatives.
1001             call sc_angular
1002             sigsq=1.0D0/sigsq
1003             sig=sig0ij*dsqrt(sigsq)
1004             rij_shift=1.0D0/rij-sig+r0ij
1005 C I hate to put IF's in the loops, but here don't have another choice!!!!
1006             if (rij_shift.le.0.0D0) then
1007               evdw=1.0D20
1008               return
1009             endif
1010             sigder=-sig*sigsq
1011 c---------------------------------------------------------------
1012             rij_shift=1.0D0/rij_shift
1013             fac=rij_shift**expon
1014             e1=fac*fac*aa(itypi,itypj)
1015             e2=fac*bb(itypi,itypj)
1016             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1017             eps2der=evdwij*eps3rt
1018             eps3der=evdwij*eps2rt
1019             fac_augm=rrij**expon
1020             e_augm=augm(itypi,itypj)*fac_augm
1021             evdwij=evdwij*eps2rt*eps3rt
1022             if (bb(itypi,itypj).gt.0.0d0) then
1023               evdw=evdw+evdwij+e_augm
1024             else
1025               evdw_t=evdw_t+evdwij+e_augm
1026             endif
1027             ij=icant(itypi,itypj)
1028             aux=eps1*eps2rt**2*eps3rt**2
1029             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1030      &        /dabs(eps(itypi,itypj))
1031             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1032 c            eneps_temp(ij)=eneps_temp(ij)
1033 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1034 c            if (lprn) then
1035 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1036 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1037 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1038 c     &        restyp(itypi),i,restyp(itypj),j,
1039 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1040 c     &        chi1,chi2,chip1,chip2,
1041 c     &        eps1,eps2rt**2,eps3rt**2,
1042 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1043 c     &        evdwij+e_augm
1044 c            endif
1045             if (calc_grad) then
1046 C Calculate gradient components.
1047             e1=e1*eps1*eps2rt**2*eps3rt**2
1048             fac=-expon*(e1+evdwij)*rij_shift
1049             sigder=fac*sigder
1050             fac=rij*fac-2*expon*rrij*e_augm
1051 C Calculate the radial part of the gradient
1052             gg(1)=xj*fac
1053             gg(2)=yj*fac
1054             gg(3)=zj*fac
1055 C Calculate angular part of the gradient.
1056             call sc_grad
1057             endif
1058           enddo      ! j
1059         enddo        ! iint
1060       enddo          ! i
1061       return
1062       end
1063 C-----------------------------------------------------------------------------
1064       subroutine sc_angular
1065 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1066 C om12. Called by ebp, egb, and egbv.
1067       implicit none
1068       include 'COMMON.CALC'
1069       erij(1)=xj*rij
1070       erij(2)=yj*rij
1071       erij(3)=zj*rij
1072       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1073       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1074       om12=dxi*dxj+dyi*dyj+dzi*dzj
1075       chiom12=chi12*om12
1076 C Calculate eps1(om12) and its derivative in om12
1077       faceps1=1.0D0-om12*chiom12
1078       faceps1_inv=1.0D0/faceps1
1079       eps1=dsqrt(faceps1_inv)
1080 C Following variable is eps1*deps1/dom12
1081       eps1_om12=faceps1_inv*chiom12
1082 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1083 C and om12.
1084       om1om2=om1*om2
1085       chiom1=chi1*om1
1086       chiom2=chi2*om2
1087       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1088       sigsq=1.0D0-facsig*faceps1_inv
1089       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1090       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1091       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1092 C Calculate eps2 and its derivatives in om1, om2, and om12.
1093       chipom1=chip1*om1
1094       chipom2=chip2*om2
1095       chipom12=chip12*om12
1096       facp=1.0D0-om12*chipom12
1097       facp_inv=1.0D0/facp
1098       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1099 C Following variable is the square root of eps2
1100       eps2rt=1.0D0-facp1*facp_inv
1101 C Following three variables are the derivatives of the square root of eps
1102 C in om1, om2, and om12.
1103       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1104       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1105       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1106 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1107       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1108 C Calculate whole angle-dependent part of epsilon and contributions
1109 C to its derivatives
1110       return
1111       end
1112 C----------------------------------------------------------------------------
1113       subroutine sc_grad
1114       implicit real*8 (a-h,o-z)
1115       include 'DIMENSIONS'
1116       include 'DIMENSIONS.ZSCOPT'
1117       include 'COMMON.CHAIN'
1118       include 'COMMON.DERIV'
1119       include 'COMMON.CALC'
1120       double precision dcosom1(3),dcosom2(3)
1121       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1122       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1123       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1124      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1125       do k=1,3
1126         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1127         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1128       enddo
1129       do k=1,3
1130         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1131       enddo
1132       do k=1,3
1133         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1134      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1135      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1136         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1137      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1138      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1139       enddo
1140 C
1141 C Calculate the components of the gradient in DC and X
1142 C
1143       do k=i,j-1
1144         do l=1,3
1145           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1146         enddo
1147       enddo
1148       return
1149       end
1150 c------------------------------------------------------------------------------
1151       subroutine vec_and_deriv
1152       implicit real*8 (a-h,o-z)
1153       include 'DIMENSIONS'
1154       include 'DIMENSIONS.ZSCOPT'
1155       include 'COMMON.IOUNITS'
1156       include 'COMMON.GEO'
1157       include 'COMMON.VAR'
1158       include 'COMMON.LOCAL'
1159       include 'COMMON.CHAIN'
1160       include 'COMMON.VECTORS'
1161       include 'COMMON.DERIV'
1162       include 'COMMON.INTERACT'
1163       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1164 C Compute the local reference systems. For reference system (i), the
1165 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1166 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1167       do i=1,nres-1
1168 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1169           if (i.eq.nres-1) then
1170 C Case of the last full residue
1171 C Compute the Z-axis
1172             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1173             costh=dcos(pi-theta(nres))
1174             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1175             do k=1,3
1176               uz(k,i)=fac*uz(k,i)
1177             enddo
1178             if (calc_grad) then
1179 C Compute the derivatives of uz
1180             uzder(1,1,1)= 0.0d0
1181             uzder(2,1,1)=-dc_norm(3,i-1)
1182             uzder(3,1,1)= dc_norm(2,i-1)
1183             uzder(1,2,1)= dc_norm(3,i-1)
1184             uzder(2,2,1)= 0.0d0
1185             uzder(3,2,1)=-dc_norm(1,i-1)
1186             uzder(1,3,1)=-dc_norm(2,i-1)
1187             uzder(2,3,1)= dc_norm(1,i-1)
1188             uzder(3,3,1)= 0.0d0
1189             uzder(1,1,2)= 0.0d0
1190             uzder(2,1,2)= dc_norm(3,i)
1191             uzder(3,1,2)=-dc_norm(2,i)
1192             uzder(1,2,2)=-dc_norm(3,i)
1193             uzder(2,2,2)= 0.0d0
1194             uzder(3,2,2)= dc_norm(1,i)
1195             uzder(1,3,2)= dc_norm(2,i)
1196             uzder(2,3,2)=-dc_norm(1,i)
1197             uzder(3,3,2)= 0.0d0
1198             endif
1199 C Compute the Y-axis
1200             facy=fac
1201             do k=1,3
1202               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1203             enddo
1204             if (calc_grad) then
1205 C Compute the derivatives of uy
1206             do j=1,3
1207               do k=1,3
1208                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1209      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1210                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1211               enddo
1212               uyder(j,j,1)=uyder(j,j,1)-costh
1213               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1214             enddo
1215             do j=1,2
1216               do k=1,3
1217                 do l=1,3
1218                   uygrad(l,k,j,i)=uyder(l,k,j)
1219                   uzgrad(l,k,j,i)=uzder(l,k,j)
1220                 enddo
1221               enddo
1222             enddo
1223             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1224             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1225             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1226             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1227             endif
1228           else
1229 C Other residues
1230 C Compute the Z-axis
1231             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1232             costh=dcos(pi-theta(i+2))
1233             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1234             do k=1,3
1235               uz(k,i)=fac*uz(k,i)
1236             enddo
1237             if (calc_grad) then
1238 C Compute the derivatives of uz
1239             uzder(1,1,1)= 0.0d0
1240             uzder(2,1,1)=-dc_norm(3,i+1)
1241             uzder(3,1,1)= dc_norm(2,i+1)
1242             uzder(1,2,1)= dc_norm(3,i+1)
1243             uzder(2,2,1)= 0.0d0
1244             uzder(3,2,1)=-dc_norm(1,i+1)
1245             uzder(1,3,1)=-dc_norm(2,i+1)
1246             uzder(2,3,1)= dc_norm(1,i+1)
1247             uzder(3,3,1)= 0.0d0
1248             uzder(1,1,2)= 0.0d0
1249             uzder(2,1,2)= dc_norm(3,i)
1250             uzder(3,1,2)=-dc_norm(2,i)
1251             uzder(1,2,2)=-dc_norm(3,i)
1252             uzder(2,2,2)= 0.0d0
1253             uzder(3,2,2)= dc_norm(1,i)
1254             uzder(1,3,2)= dc_norm(2,i)
1255             uzder(2,3,2)=-dc_norm(1,i)
1256             uzder(3,3,2)= 0.0d0
1257             endif
1258 C Compute the Y-axis
1259             facy=fac
1260             do k=1,3
1261               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1262             enddo
1263             if (calc_grad) then
1264 C Compute the derivatives of uy
1265             do j=1,3
1266               do k=1,3
1267                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1268      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1269                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1270               enddo
1271               uyder(j,j,1)=uyder(j,j,1)-costh
1272               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1273             enddo
1274             do j=1,2
1275               do k=1,3
1276                 do l=1,3
1277                   uygrad(l,k,j,i)=uyder(l,k,j)
1278                   uzgrad(l,k,j,i)=uzder(l,k,j)
1279                 enddo
1280               enddo
1281             enddo
1282             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1283             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1284             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1285             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1286           endif
1287           endif
1288       enddo
1289       if (calc_grad) then
1290       do i=1,nres-1
1291         vbld_inv_temp(1)=vbld_inv(i+1)
1292         if (i.lt.nres-1) then
1293           vbld_inv_temp(2)=vbld_inv(i+2)
1294         else
1295           vbld_inv_temp(2)=vbld_inv(i)
1296         endif
1297         do j=1,2
1298           do k=1,3
1299             do l=1,3
1300               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1301               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1302             enddo
1303           enddo
1304         enddo
1305       enddo
1306       endif
1307       return
1308       end
1309 C-----------------------------------------------------------------------------
1310       subroutine vec_and_deriv_test
1311       implicit real*8 (a-h,o-z)
1312       include 'DIMENSIONS'
1313       include 'DIMENSIONS.ZSCOPT'
1314       include 'COMMON.IOUNITS'
1315       include 'COMMON.GEO'
1316       include 'COMMON.VAR'
1317       include 'COMMON.LOCAL'
1318       include 'COMMON.CHAIN'
1319       include 'COMMON.VECTORS'
1320       dimension uyder(3,3,2),uzder(3,3,2)
1321 C Compute the local reference systems. For reference system (i), the
1322 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1323 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1324       do i=1,nres-1
1325           if (i.eq.nres-1) then
1326 C Case of the last full residue
1327 C Compute the Z-axis
1328             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1329             costh=dcos(pi-theta(nres))
1330             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1331 c            write (iout,*) 'fac',fac,
1332 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1333             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1334             do k=1,3
1335               uz(k,i)=fac*uz(k,i)
1336             enddo
1337 C Compute the derivatives of uz
1338             uzder(1,1,1)= 0.0d0
1339             uzder(2,1,1)=-dc_norm(3,i-1)
1340             uzder(3,1,1)= dc_norm(2,i-1)
1341             uzder(1,2,1)= dc_norm(3,i-1)
1342             uzder(2,2,1)= 0.0d0
1343             uzder(3,2,1)=-dc_norm(1,i-1)
1344             uzder(1,3,1)=-dc_norm(2,i-1)
1345             uzder(2,3,1)= dc_norm(1,i-1)
1346             uzder(3,3,1)= 0.0d0
1347             uzder(1,1,2)= 0.0d0
1348             uzder(2,1,2)= dc_norm(3,i)
1349             uzder(3,1,2)=-dc_norm(2,i)
1350             uzder(1,2,2)=-dc_norm(3,i)
1351             uzder(2,2,2)= 0.0d0
1352             uzder(3,2,2)= dc_norm(1,i)
1353             uzder(1,3,2)= dc_norm(2,i)
1354             uzder(2,3,2)=-dc_norm(1,i)
1355             uzder(3,3,2)= 0.0d0
1356 C Compute the Y-axis
1357             do k=1,3
1358               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1359             enddo
1360             facy=fac
1361             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1362      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1363      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1364             do k=1,3
1365 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1366               uy(k,i)=
1367 c     &        facy*(
1368      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1369      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1370 c     &        )
1371             enddo
1372 c            write (iout,*) 'facy',facy,
1373 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1374             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1375             do k=1,3
1376               uy(k,i)=facy*uy(k,i)
1377             enddo
1378 C Compute the derivatives of uy
1379             do j=1,3
1380               do k=1,3
1381                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1382      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1383                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1384               enddo
1385 c              uyder(j,j,1)=uyder(j,j,1)-costh
1386 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1387               uyder(j,j,1)=uyder(j,j,1)
1388      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1389               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1390      &          +uyder(j,j,2)
1391             enddo
1392             do j=1,2
1393               do k=1,3
1394                 do l=1,3
1395                   uygrad(l,k,j,i)=uyder(l,k,j)
1396                   uzgrad(l,k,j,i)=uzder(l,k,j)
1397                 enddo
1398               enddo
1399             enddo
1400             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1401             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1402             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1403             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1404           else
1405 C Other residues
1406 C Compute the Z-axis
1407             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1408             costh=dcos(pi-theta(i+2))
1409             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1410             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1411             do k=1,3
1412               uz(k,i)=fac*uz(k,i)
1413             enddo
1414 C Compute the derivatives of uz
1415             uzder(1,1,1)= 0.0d0
1416             uzder(2,1,1)=-dc_norm(3,i+1)
1417             uzder(3,1,1)= dc_norm(2,i+1)
1418             uzder(1,2,1)= dc_norm(3,i+1)
1419             uzder(2,2,1)= 0.0d0
1420             uzder(3,2,1)=-dc_norm(1,i+1)
1421             uzder(1,3,1)=-dc_norm(2,i+1)
1422             uzder(2,3,1)= dc_norm(1,i+1)
1423             uzder(3,3,1)= 0.0d0
1424             uzder(1,1,2)= 0.0d0
1425             uzder(2,1,2)= dc_norm(3,i)
1426             uzder(3,1,2)=-dc_norm(2,i)
1427             uzder(1,2,2)=-dc_norm(3,i)
1428             uzder(2,2,2)= 0.0d0
1429             uzder(3,2,2)= dc_norm(1,i)
1430             uzder(1,3,2)= dc_norm(2,i)
1431             uzder(2,3,2)=-dc_norm(1,i)
1432             uzder(3,3,2)= 0.0d0
1433 C Compute the Y-axis
1434             facy=fac
1435             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1436      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1437      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1438             do k=1,3
1439 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1440               uy(k,i)=
1441 c     &        facy*(
1442      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1443      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1444 c     &        )
1445             enddo
1446 c            write (iout,*) 'facy',facy,
1447 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1448             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1449             do k=1,3
1450               uy(k,i)=facy*uy(k,i)
1451             enddo
1452 C Compute the derivatives of uy
1453             do j=1,3
1454               do k=1,3
1455                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1456      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1457                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1458               enddo
1459 c              uyder(j,j,1)=uyder(j,j,1)-costh
1460 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1461               uyder(j,j,1)=uyder(j,j,1)
1462      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1463               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1464      &          +uyder(j,j,2)
1465             enddo
1466             do j=1,2
1467               do k=1,3
1468                 do l=1,3
1469                   uygrad(l,k,j,i)=uyder(l,k,j)
1470                   uzgrad(l,k,j,i)=uzder(l,k,j)
1471                 enddo
1472               enddo
1473             enddo
1474             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1475             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1476             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1477             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1478           endif
1479       enddo
1480       do i=1,nres-1
1481         do j=1,2
1482           do k=1,3
1483             do l=1,3
1484               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1485               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1486             enddo
1487           enddo
1488         enddo
1489       enddo
1490       return
1491       end
1492 C-----------------------------------------------------------------------------
1493       subroutine check_vecgrad
1494       implicit real*8 (a-h,o-z)
1495       include 'DIMENSIONS'
1496       include 'DIMENSIONS.ZSCOPT'
1497       include 'COMMON.IOUNITS'
1498       include 'COMMON.GEO'
1499       include 'COMMON.VAR'
1500       include 'COMMON.LOCAL'
1501       include 'COMMON.CHAIN'
1502       include 'COMMON.VECTORS'
1503       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1504       dimension uyt(3,maxres),uzt(3,maxres)
1505       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1506       double precision delta /1.0d-7/
1507       call vec_and_deriv
1508 cd      do i=1,nres
1509 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1510 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1511 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1512 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1513 cd     &     (dc_norm(if90,i),if90=1,3)
1514 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1515 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1516 cd          write(iout,'(a)')
1517 cd      enddo
1518       do i=1,nres
1519         do j=1,2
1520           do k=1,3
1521             do l=1,3
1522               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1523               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1524             enddo
1525           enddo
1526         enddo
1527       enddo
1528       call vec_and_deriv
1529       do i=1,nres
1530         do j=1,3
1531           uyt(j,i)=uy(j,i)
1532           uzt(j,i)=uz(j,i)
1533         enddo
1534       enddo
1535       do i=1,nres
1536 cd        write (iout,*) 'i=',i
1537         do k=1,3
1538           erij(k)=dc_norm(k,i)
1539         enddo
1540         do j=1,3
1541           do k=1,3
1542             dc_norm(k,i)=erij(k)
1543           enddo
1544           dc_norm(j,i)=dc_norm(j,i)+delta
1545 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1546 c          do k=1,3
1547 c            dc_norm(k,i)=dc_norm(k,i)/fac
1548 c          enddo
1549 c          write (iout,*) (dc_norm(k,i),k=1,3)
1550 c          write (iout,*) (erij(k),k=1,3)
1551           call vec_and_deriv
1552           do k=1,3
1553             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1554             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1555             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1556             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1557           enddo
1558 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1559 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1560 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1561         enddo
1562         do k=1,3
1563           dc_norm(k,i)=erij(k)
1564         enddo
1565 cd        do k=1,3
1566 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1567 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1568 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1569 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1570 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1571 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1572 cd          write (iout,'(a)')
1573 cd        enddo
1574       enddo
1575       return
1576       end
1577 C--------------------------------------------------------------------------
1578       subroutine set_matrices
1579       implicit real*8 (a-h,o-z)
1580       include 'DIMENSIONS'
1581       include 'DIMENSIONS.ZSCOPT'
1582       include 'COMMON.IOUNITS'
1583       include 'COMMON.GEO'
1584       include 'COMMON.VAR'
1585       include 'COMMON.LOCAL'
1586       include 'COMMON.CHAIN'
1587       include 'COMMON.DERIV'
1588       include 'COMMON.INTERACT'
1589       include 'COMMON.CONTACTS'
1590       include 'COMMON.TORSION'
1591       include 'COMMON.VECTORS'
1592       include 'COMMON.FFIELD'
1593       double precision auxvec(2),auxmat(2,2)
1594 C
1595 C Compute the virtual-bond-torsional-angle dependent quantities needed
1596 C to calculate the el-loc multibody terms of various order.
1597 C
1598       do i=3,nres+1
1599         if (i .lt. nres+1) then
1600           sin1=dsin(phi(i))
1601           cos1=dcos(phi(i))
1602           sintab(i-2)=sin1
1603           costab(i-2)=cos1
1604           obrot(1,i-2)=cos1
1605           obrot(2,i-2)=sin1
1606           sin2=dsin(2*phi(i))
1607           cos2=dcos(2*phi(i))
1608           sintab2(i-2)=sin2
1609           costab2(i-2)=cos2
1610           obrot2(1,i-2)=cos2
1611           obrot2(2,i-2)=sin2
1612           Ug(1,1,i-2)=-cos1
1613           Ug(1,2,i-2)=-sin1
1614           Ug(2,1,i-2)=-sin1
1615           Ug(2,2,i-2)= cos1
1616           Ug2(1,1,i-2)=-cos2
1617           Ug2(1,2,i-2)=-sin2
1618           Ug2(2,1,i-2)=-sin2
1619           Ug2(2,2,i-2)= cos2
1620         else
1621           costab(i-2)=1.0d0
1622           sintab(i-2)=0.0d0
1623           obrot(1,i-2)=1.0d0
1624           obrot(2,i-2)=0.0d0
1625           obrot2(1,i-2)=0.0d0
1626           obrot2(2,i-2)=0.0d0
1627           Ug(1,1,i-2)=1.0d0
1628           Ug(1,2,i-2)=0.0d0
1629           Ug(2,1,i-2)=0.0d0
1630           Ug(2,2,i-2)=1.0d0
1631           Ug2(1,1,i-2)=0.0d0
1632           Ug2(1,2,i-2)=0.0d0
1633           Ug2(2,1,i-2)=0.0d0
1634           Ug2(2,2,i-2)=0.0d0
1635         endif
1636         if (i .gt. 3 .and. i .lt. nres+1) then
1637           obrot_der(1,i-2)=-sin1
1638           obrot_der(2,i-2)= cos1
1639           Ugder(1,1,i-2)= sin1
1640           Ugder(1,2,i-2)=-cos1
1641           Ugder(2,1,i-2)=-cos1
1642           Ugder(2,2,i-2)=-sin1
1643           dwacos2=cos2+cos2
1644           dwasin2=sin2+sin2
1645           obrot2_der(1,i-2)=-dwasin2
1646           obrot2_der(2,i-2)= dwacos2
1647           Ug2der(1,1,i-2)= dwasin2
1648           Ug2der(1,2,i-2)=-dwacos2
1649           Ug2der(2,1,i-2)=-dwacos2
1650           Ug2der(2,2,i-2)=-dwasin2
1651         else
1652           obrot_der(1,i-2)=0.0d0
1653           obrot_der(2,i-2)=0.0d0
1654           Ugder(1,1,i-2)=0.0d0
1655           Ugder(1,2,i-2)=0.0d0
1656           Ugder(2,1,i-2)=0.0d0
1657           Ugder(2,2,i-2)=0.0d0
1658           obrot2_der(1,i-2)=0.0d0
1659           obrot2_der(2,i-2)=0.0d0
1660           Ug2der(1,1,i-2)=0.0d0
1661           Ug2der(1,2,i-2)=0.0d0
1662           Ug2der(2,1,i-2)=0.0d0
1663           Ug2der(2,2,i-2)=0.0d0
1664         endif
1665         if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1666           iti = itortyp(itype(i-2))
1667         else
1668           iti=ntortyp+1
1669         endif
1670         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1671           iti1 = itortyp(itype(i-1))
1672         else
1673           iti1=ntortyp+1
1674         endif
1675 cd        write (iout,*) '*******i',i,' iti1',iti
1676 cd        write (iout,*) 'b1',b1(:,iti)
1677 cd        write (iout,*) 'b2',b2(:,iti)
1678 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1679         if (i .gt. iatel_s+2) then
1680           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1681           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1682           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1683           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1684           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1685           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1686           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1687         else
1688           do k=1,2
1689             Ub2(k,i-2)=0.0d0
1690             Ctobr(k,i-2)=0.0d0
1691             Dtobr2(k,i-2)=0.0d0
1692             do l=1,2
1693               EUg(l,k,i-2)=0.0d0
1694               CUg(l,k,i-2)=0.0d0
1695               DUg(l,k,i-2)=0.0d0
1696               DtUg2(l,k,i-2)=0.0d0
1697             enddo
1698           enddo
1699         endif
1700         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1701         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1702         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1703         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1704         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1705         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1706         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1707         do k=1,2
1708           muder(k,i-2)=Ub2der(k,i-2)
1709         enddo
1710         if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1711           iti1 = itortyp(itype(i-1))
1712         else
1713           iti1=ntortyp+1
1714         endif
1715         do k=1,2
1716           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1717         enddo
1718 C Vectors and matrices dependent on a single virtual-bond dihedral.
1719         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1720         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1721         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1722         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1723         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1724         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1725         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1726         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1727         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1728 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1729 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1730       enddo
1731 C Matrices dependent on two consecutive virtual-bond dihedrals.
1732 C The order of matrices is from left to right.
1733       do i=2,nres-1
1734         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1735         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1736         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1737         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1738         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1739         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1740         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1741         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1742       enddo
1743 cd      do i=1,nres
1744 cd        iti = itortyp(itype(i))
1745 cd        write (iout,*) i
1746 cd        do j=1,2
1747 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1748 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1749 cd        enddo
1750 cd      enddo
1751       return
1752       end
1753 C--------------------------------------------------------------------------
1754       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1755 C
1756 C This subroutine calculates the average interaction energy and its gradient
1757 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1758 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1759 C The potential depends both on the distance of peptide-group centers and on
1760 C the orientation of the CA-CA virtual bonds.
1761 C
1762       implicit real*8 (a-h,o-z)
1763       include 'DIMENSIONS'
1764       include 'DIMENSIONS.ZSCOPT'
1765       include 'COMMON.CONTROL'
1766       include 'COMMON.IOUNITS'
1767       include 'COMMON.GEO'
1768       include 'COMMON.VAR'
1769       include 'COMMON.LOCAL'
1770       include 'COMMON.CHAIN'
1771       include 'COMMON.DERIV'
1772       include 'COMMON.INTERACT'
1773       include 'COMMON.CONTACTS'
1774       include 'COMMON.TORSION'
1775       include 'COMMON.VECTORS'
1776       include 'COMMON.FFIELD'
1777       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1778      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1779       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1780      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1781       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1782 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1783       double precision scal_el /0.5d0/
1784 C 12/13/98
1785 C 13-go grudnia roku pamietnego...
1786       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1787      &                   0.0d0,1.0d0,0.0d0,
1788      &                   0.0d0,0.0d0,1.0d0/
1789 cd      write(iout,*) 'In EELEC'
1790 cd      do i=1,nloctyp
1791 cd        write(iout,*) 'Type',i
1792 cd        write(iout,*) 'B1',B1(:,i)
1793 cd        write(iout,*) 'B2',B2(:,i)
1794 cd        write(iout,*) 'CC',CC(:,:,i)
1795 cd        write(iout,*) 'DD',DD(:,:,i)
1796 cd        write(iout,*) 'EE',EE(:,:,i)
1797 cd      enddo
1798 cd      call check_vecgrad
1799 cd      stop
1800       if (icheckgrad.eq.1) then
1801         do i=1,nres-1
1802           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1803           do k=1,3
1804             dc_norm(k,i)=dc(k,i)*fac
1805           enddo
1806 c          write (iout,*) 'i',i,' fac',fac
1807         enddo
1808       endif
1809       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1810      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1811      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1812 cd      if (wel_loc.gt.0.0d0) then
1813         if (icheckgrad.eq.1) then
1814         call vec_and_deriv_test
1815         else
1816         call vec_and_deriv
1817         endif
1818         call set_matrices
1819       endif
1820 cd      do i=1,nres-1
1821 cd        write (iout,*) 'i=',i
1822 cd        do k=1,3
1823 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1824 cd        enddo
1825 cd        do k=1,3
1826 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
1827 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
1828 cd        enddo
1829 cd      enddo
1830       num_conti_hb=0
1831       ees=0.0D0
1832       evdw1=0.0D0
1833       eel_loc=0.0d0
1834       eello_turn3=0.0d0
1835       eello_turn4=0.0d0
1836       ind=0
1837       do i=1,nres
1838         num_cont_hb(i)=0
1839       enddo
1840 cd      print '(a)','Enter EELEC'
1841 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
1842       do i=1,nres
1843         gel_loc_loc(i)=0.0d0
1844         gcorr_loc(i)=0.0d0
1845       enddo
1846       do i=iatel_s,iatel_e
1847         if (itel(i).eq.0) goto 1215
1848         dxi=dc(1,i)
1849         dyi=dc(2,i)
1850         dzi=dc(3,i)
1851         dx_normi=dc_norm(1,i)
1852         dy_normi=dc_norm(2,i)
1853         dz_normi=dc_norm(3,i)
1854         xmedi=c(1,i)+0.5d0*dxi
1855         ymedi=c(2,i)+0.5d0*dyi
1856         zmedi=c(3,i)+0.5d0*dzi
1857         num_conti=0
1858 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1859         do j=ielstart(i),ielend(i)
1860           if (itel(j).eq.0) goto 1216
1861           ind=ind+1
1862           iteli=itel(i)
1863           itelj=itel(j)
1864           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1865           aaa=app(iteli,itelj)
1866           bbb=bpp(iteli,itelj)
1867 C Diagnostics only!!!
1868 c         aaa=0.0D0
1869 c         bbb=0.0D0
1870 c         ael6i=0.0D0
1871 c         ael3i=0.0D0
1872 C End diagnostics
1873           ael6i=ael6(iteli,itelj)
1874           ael3i=ael3(iteli,itelj)
1875           dxj=dc(1,j)
1876           dyj=dc(2,j)
1877           dzj=dc(3,j)
1878           dx_normj=dc_norm(1,j)
1879           dy_normj=dc_norm(2,j)
1880           dz_normj=dc_norm(3,j)
1881           xj=c(1,j)+0.5D0*dxj-xmedi
1882           yj=c(2,j)+0.5D0*dyj-ymedi
1883           zj=c(3,j)+0.5D0*dzj-zmedi
1884           rij=xj*xj+yj*yj+zj*zj
1885           rrmij=1.0D0/rij
1886           rij=dsqrt(rij)
1887           rmij=1.0D0/rij
1888           r3ij=rrmij*rmij
1889           r6ij=r3ij*r3ij
1890           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
1891           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
1892           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
1893           fac=cosa-3.0D0*cosb*cosg
1894           ev1=aaa*r6ij*r6ij
1895 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
1896           if (j.eq.i+2) ev1=scal_el*ev1
1897           ev2=bbb*r6ij
1898           fac3=ael6i*r6ij
1899           fac4=ael3i*r3ij
1900           evdwij=ev1+ev2
1901           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
1902           el2=fac4*fac
1903           eesij=el1+el2
1904 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
1905 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
1906           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
1907           ees=ees+eesij
1908           evdw1=evdw1+evdwij
1909 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
1910 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
1911 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
1912 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
1913 C
1914 C Calculate contributions to the Cartesian gradient.
1915 C
1916 #ifdef SPLITELE
1917           facvdw=-6*rrmij*(ev1+evdwij)
1918           facel=-3*rrmij*(el1+eesij)
1919           fac1=fac
1920           erij(1)=xj*rmij
1921           erij(2)=yj*rmij
1922           erij(3)=zj*rmij
1923           if (calc_grad) then
1924 *
1925 * Radial derivatives. First process both termini of the fragment (i,j)
1926 *
1927           ggg(1)=facel*xj
1928           ggg(2)=facel*yj
1929           ggg(3)=facel*zj
1930           do k=1,3
1931             ghalf=0.5D0*ggg(k)
1932             gelc(k,i)=gelc(k,i)+ghalf
1933             gelc(k,j)=gelc(k,j)+ghalf
1934           enddo
1935 *
1936 * Loop over residues i+1 thru j-1.
1937 *
1938           do k=i+1,j-1
1939             do l=1,3
1940               gelc(l,k)=gelc(l,k)+ggg(l)
1941             enddo
1942           enddo
1943           ggg(1)=facvdw*xj
1944           ggg(2)=facvdw*yj
1945           ggg(3)=facvdw*zj
1946           do k=1,3
1947             ghalf=0.5D0*ggg(k)
1948             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
1949             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
1950           enddo
1951 *
1952 * Loop over residues i+1 thru j-1.
1953 *
1954           do k=i+1,j-1
1955             do l=1,3
1956               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
1957             enddo
1958           enddo
1959 #else
1960           facvdw=ev1+evdwij
1961           facel=el1+eesij
1962           fac1=fac
1963           fac=-3*rrmij*(facvdw+facvdw+facel)
1964           erij(1)=xj*rmij
1965           erij(2)=yj*rmij
1966           erij(3)=zj*rmij
1967           if (calc_grad) then
1968 *
1969 * Radial derivatives. First process both termini of the fragment (i,j)
1970 *
1971           ggg(1)=fac*xj
1972           ggg(2)=fac*yj
1973           ggg(3)=fac*zj
1974           do k=1,3
1975             ghalf=0.5D0*ggg(k)
1976             gelc(k,i)=gelc(k,i)+ghalf
1977             gelc(k,j)=gelc(k,j)+ghalf
1978           enddo
1979 *
1980 * Loop over residues i+1 thru j-1.
1981 *
1982           do k=i+1,j-1
1983             do l=1,3
1984               gelc(l,k)=gelc(l,k)+ggg(l)
1985             enddo
1986           enddo
1987 #endif
1988 *
1989 * Angular part
1990 *
1991           ecosa=2.0D0*fac3*fac1+fac4
1992           fac4=-3.0D0*fac4
1993           fac3=-6.0D0*fac3
1994           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
1995           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
1996           do k=1,3
1997             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
1998             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
1999           enddo
2000 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2001 cd   &          (dcosg(k),k=1,3)
2002           do k=1,3
2003             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2004           enddo
2005           do k=1,3
2006             ghalf=0.5D0*ggg(k)
2007             gelc(k,i)=gelc(k,i)+ghalf
2008      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2009      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2010             gelc(k,j)=gelc(k,j)+ghalf
2011      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2012      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2013           enddo
2014           do k=i+1,j-1
2015             do l=1,3
2016               gelc(l,k)=gelc(l,k)+ggg(l)
2017             enddo
2018           enddo
2019           endif
2020
2021           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2022      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2023      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2024 C
2025 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2026 C   energy of a peptide unit is assumed in the form of a second-order
2027 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2028 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2029 C   are computed for EVERY pair of non-contiguous peptide groups.
2030 C
2031           if (j.lt.nres-1) then
2032             j1=j+1
2033             j2=j-1
2034           else
2035             j1=j-1
2036             j2=j-2
2037           endif
2038           kkk=0
2039           do k=1,2
2040             do l=1,2
2041               kkk=kkk+1
2042               muij(kkk)=mu(k,i)*mu(l,j)
2043             enddo
2044           enddo
2045 cd         write (iout,*) 'EELEC: i',i,' j',j
2046 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2047 cd          write(iout,*) 'muij',muij
2048           ury=scalar(uy(1,i),erij)
2049           urz=scalar(uz(1,i),erij)
2050           vry=scalar(uy(1,j),erij)
2051           vrz=scalar(uz(1,j),erij)
2052           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2053           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2054           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2055           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2056 C For diagnostics only
2057 cd          a22=1.0d0
2058 cd          a23=1.0d0
2059 cd          a32=1.0d0
2060 cd          a33=1.0d0
2061           fac=dsqrt(-ael6i)*r3ij
2062 cd          write (2,*) 'fac=',fac
2063 C For diagnostics only
2064 cd          fac=1.0d0
2065           a22=a22*fac
2066           a23=a23*fac
2067           a32=a32*fac
2068           a33=a33*fac
2069 cd          write (iout,'(4i5,4f10.5)')
2070 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2071 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2072 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2073 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2074 cd          write (iout,'(4f10.5)')
2075 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2076 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2077 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2078 cd           write (iout,'(2i3,9f10.5/)') i,j,
2079 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2080           if (calc_grad) then
2081 C Derivatives of the elements of A in virtual-bond vectors
2082           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2083 cd          do k=1,3
2084 cd            do l=1,3
2085 cd              erder(k,l)=0.0d0
2086 cd            enddo
2087 cd          enddo
2088           do k=1,3
2089             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2090             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2091             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2092             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2093             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2094             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2095             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2096             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2097             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2098             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2099             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2100             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2101           enddo
2102 cd          do k=1,3
2103 cd            do l=1,3
2104 cd              uryg(k,l)=0.0d0
2105 cd              urzg(k,l)=0.0d0
2106 cd              vryg(k,l)=0.0d0
2107 cd              vrzg(k,l)=0.0d0
2108 cd            enddo
2109 cd          enddo
2110 C Compute radial contributions to the gradient
2111           facr=-3.0d0*rrmij
2112           a22der=a22*facr
2113           a23der=a23*facr
2114           a32der=a32*facr
2115           a33der=a33*facr
2116 cd          a22der=0.0d0
2117 cd          a23der=0.0d0
2118 cd          a32der=0.0d0
2119 cd          a33der=0.0d0
2120           agg(1,1)=a22der*xj
2121           agg(2,1)=a22der*yj
2122           agg(3,1)=a22der*zj
2123           agg(1,2)=a23der*xj
2124           agg(2,2)=a23der*yj
2125           agg(3,2)=a23der*zj
2126           agg(1,3)=a32der*xj
2127           agg(2,3)=a32der*yj
2128           agg(3,3)=a32der*zj
2129           agg(1,4)=a33der*xj
2130           agg(2,4)=a33der*yj
2131           agg(3,4)=a33der*zj
2132 C Add the contributions coming from er
2133           fac3=-3.0d0*fac
2134           do k=1,3
2135             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2136             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2137             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2138             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2139           enddo
2140           do k=1,3
2141 C Derivatives in DC(i)
2142             ghalf1=0.5d0*agg(k,1)
2143             ghalf2=0.5d0*agg(k,2)
2144             ghalf3=0.5d0*agg(k,3)
2145             ghalf4=0.5d0*agg(k,4)
2146             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2147      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2148             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2149      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2150             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2151      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2152             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2153      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2154 C Derivatives in DC(i+1)
2155             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2156      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2157             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2158      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2159             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2160      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2161             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2162      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2163 C Derivatives in DC(j)
2164             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2165      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2166             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2167      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2168             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2169      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2170             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2171      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2172 C Derivatives in DC(j+1) or DC(nres-1)
2173             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2174      &      -3.0d0*vryg(k,3)*ury)
2175             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2176      &      -3.0d0*vrzg(k,3)*ury)
2177             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2178      &      -3.0d0*vryg(k,3)*urz)
2179             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2180      &      -3.0d0*vrzg(k,3)*urz)
2181 cd            aggi(k,1)=ghalf1
2182 cd            aggi(k,2)=ghalf2
2183 cd            aggi(k,3)=ghalf3
2184 cd            aggi(k,4)=ghalf4
2185 C Derivatives in DC(i+1)
2186 cd            aggi1(k,1)=agg(k,1)
2187 cd            aggi1(k,2)=agg(k,2)
2188 cd            aggi1(k,3)=agg(k,3)
2189 cd            aggi1(k,4)=agg(k,4)
2190 C Derivatives in DC(j)
2191 cd            aggj(k,1)=ghalf1
2192 cd            aggj(k,2)=ghalf2
2193 cd            aggj(k,3)=ghalf3
2194 cd            aggj(k,4)=ghalf4
2195 C Derivatives in DC(j+1)
2196 cd            aggj1(k,1)=0.0d0
2197 cd            aggj1(k,2)=0.0d0
2198 cd            aggj1(k,3)=0.0d0
2199 cd            aggj1(k,4)=0.0d0
2200             if (j.eq.nres-1 .and. i.lt.j-2) then
2201               do l=1,4
2202                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2203 cd                aggj1(k,l)=agg(k,l)
2204               enddo
2205             endif
2206           enddo
2207           endif
2208 c          goto 11111
2209 C Check the loc-el terms by numerical integration
2210           acipa(1,1)=a22
2211           acipa(1,2)=a23
2212           acipa(2,1)=a32
2213           acipa(2,2)=a33
2214           a22=-a22
2215           a23=-a23
2216           do l=1,2
2217             do k=1,3
2218               agg(k,l)=-agg(k,l)
2219               aggi(k,l)=-aggi(k,l)
2220               aggi1(k,l)=-aggi1(k,l)
2221               aggj(k,l)=-aggj(k,l)
2222               aggj1(k,l)=-aggj1(k,l)
2223             enddo
2224           enddo
2225           if (j.lt.nres-1) then
2226             a22=-a22
2227             a32=-a32
2228             do l=1,3,2
2229               do k=1,3
2230                 agg(k,l)=-agg(k,l)
2231                 aggi(k,l)=-aggi(k,l)
2232                 aggi1(k,l)=-aggi1(k,l)
2233                 aggj(k,l)=-aggj(k,l)
2234                 aggj1(k,l)=-aggj1(k,l)
2235               enddo
2236             enddo
2237           else
2238             a22=-a22
2239             a23=-a23
2240             a32=-a32
2241             a33=-a33
2242             do l=1,4
2243               do k=1,3
2244                 agg(k,l)=-agg(k,l)
2245                 aggi(k,l)=-aggi(k,l)
2246                 aggi1(k,l)=-aggi1(k,l)
2247                 aggj(k,l)=-aggj(k,l)
2248                 aggj1(k,l)=-aggj1(k,l)
2249               enddo
2250             enddo
2251           endif
2252           ENDIF ! WCORR
2253 11111     continue
2254           IF (wel_loc.gt.0.0d0) THEN
2255 C Contribution to the local-electrostatic energy coming from the i-j pair
2256           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2257      &     +a33*muij(4)
2258 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2259 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2260           eel_loc=eel_loc+eel_loc_ij
2261 C Partial derivatives in virtual-bond dihedral angles gamma
2262           if (calc_grad) then
2263           if (i.gt.1)
2264      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2265      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2266      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2267           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2268      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2269      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2270 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2271 cd          write(iout,*) 'agg  ',agg
2272 cd          write(iout,*) 'aggi ',aggi
2273 cd          write(iout,*) 'aggi1',aggi1
2274 cd          write(iout,*) 'aggj ',aggj
2275 cd          write(iout,*) 'aggj1',aggj1
2276
2277 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2278           do l=1,3
2279             ggg(l)=agg(l,1)*muij(1)+
2280      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2281           enddo
2282           do k=i+2,j2
2283             do l=1,3
2284               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2285             enddo
2286           enddo
2287 C Remaining derivatives of eello
2288           do l=1,3
2289             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2290      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2291             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2292      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2293             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2294      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2295             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2296      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2297           enddo
2298           endif
2299           ENDIF
2300           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2301 C Contributions from turns
2302             a_temp(1,1)=a22
2303             a_temp(1,2)=a23
2304             a_temp(2,1)=a32
2305             a_temp(2,2)=a33
2306             call eturn34(i,j,eello_turn3,eello_turn4)
2307           endif
2308 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2309           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2310 C
2311 C Calculate the contact function. The ith column of the array JCONT will
2312 C contain the numbers of atoms that make contacts with the atom I (of numbers
2313 C greater than I). The arrays FACONT and GACONT will contain the values of
2314 C the contact function and its derivative.
2315 c           r0ij=1.02D0*rpp(iteli,itelj)
2316 c           r0ij=1.11D0*rpp(iteli,itelj)
2317             r0ij=2.20D0*rpp(iteli,itelj)
2318 c           r0ij=1.55D0*rpp(iteli,itelj)
2319             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2320             if (fcont.gt.0.0D0) then
2321               num_conti=num_conti+1
2322               if (num_conti.gt.maxconts) then
2323                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2324      &                         ' will skip next contacts for this conf.'
2325               else
2326                 jcont_hb(num_conti,i)=j
2327                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2328      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2329 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2330 C  terms.
2331                 d_cont(num_conti,i)=rij
2332 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2333 C     --- Electrostatic-interaction matrix ---
2334                 a_chuj(1,1,num_conti,i)=a22
2335                 a_chuj(1,2,num_conti,i)=a23
2336                 a_chuj(2,1,num_conti,i)=a32
2337                 a_chuj(2,2,num_conti,i)=a33
2338 C     --- Gradient of rij
2339                 do kkk=1,3
2340                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2341                 enddo
2342 c             if (i.eq.1) then
2343 c                a_chuj(1,1,num_conti,i)=-0.61d0
2344 c                a_chuj(1,2,num_conti,i)= 0.4d0
2345 c                a_chuj(2,1,num_conti,i)= 0.65d0
2346 c                a_chuj(2,2,num_conti,i)= 0.50d0
2347 c             else if (i.eq.2) then
2348 c                a_chuj(1,1,num_conti,i)= 0.0d0
2349 c                a_chuj(1,2,num_conti,i)= 0.0d0
2350 c                a_chuj(2,1,num_conti,i)= 0.0d0
2351 c                a_chuj(2,2,num_conti,i)= 0.0d0
2352 c             endif
2353 C     --- and its gradients
2354 cd                write (iout,*) 'i',i,' j',j
2355 cd                do kkk=1,3
2356 cd                write (iout,*) 'iii 1 kkk',kkk
2357 cd                write (iout,*) agg(kkk,:)
2358 cd                enddo
2359 cd                do kkk=1,3
2360 cd                write (iout,*) 'iii 2 kkk',kkk
2361 cd                write (iout,*) aggi(kkk,:)
2362 cd                enddo
2363 cd                do kkk=1,3
2364 cd                write (iout,*) 'iii 3 kkk',kkk
2365 cd                write (iout,*) aggi1(kkk,:)
2366 cd                enddo
2367 cd                do kkk=1,3
2368 cd                write (iout,*) 'iii 4 kkk',kkk
2369 cd                write (iout,*) aggj(kkk,:)
2370 cd                enddo
2371 cd                do kkk=1,3
2372 cd                write (iout,*) 'iii 5 kkk',kkk
2373 cd                write (iout,*) aggj1(kkk,:)
2374 cd                enddo
2375                 kkll=0
2376                 do k=1,2
2377                   do l=1,2
2378                     kkll=kkll+1
2379                     do m=1,3
2380                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2381                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2382                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2383                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2384                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2385 c                      do mm=1,5
2386 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2387 c                      enddo
2388                     enddo
2389                   enddo
2390                 enddo
2391                 ENDIF
2392                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2393 C Calculate contact energies
2394                 cosa4=4.0D0*cosa
2395                 wij=cosa-3.0D0*cosb*cosg
2396                 cosbg1=cosb+cosg
2397                 cosbg2=cosb-cosg
2398 c               fac3=dsqrt(-ael6i)/r0ij**3
2399                 fac3=dsqrt(-ael6i)*r3ij
2400                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2401                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2402 c               ees0mij=0.0D0
2403                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2404                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2405 C Diagnostics. Comment out or remove after debugging!
2406 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2407 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2408 c               ees0m(num_conti,i)=0.0D0
2409 C End diagnostics.
2410 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2411 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2412                 facont_hb(num_conti,i)=fcont
2413                 if (calc_grad) then
2414 C Angular derivatives of the contact function
2415                 ees0pij1=fac3/ees0pij
2416                 ees0mij1=fac3/ees0mij
2417                 fac3p=-3.0D0*fac3*rrmij
2418                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2419                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2420 c               ees0mij1=0.0D0
2421                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2422                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2423                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2424                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2425                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2426                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2427                 ecosap=ecosa1+ecosa2
2428                 ecosbp=ecosb1+ecosb2
2429                 ecosgp=ecosg1+ecosg2
2430                 ecosam=ecosa1-ecosa2
2431                 ecosbm=ecosb1-ecosb2
2432                 ecosgm=ecosg1-ecosg2
2433 C Diagnostics
2434 c               ecosap=ecosa1
2435 c               ecosbp=ecosb1
2436 c               ecosgp=ecosg1
2437 c               ecosam=0.0D0
2438 c               ecosbm=0.0D0
2439 c               ecosgm=0.0D0
2440 C End diagnostics
2441                 fprimcont=fprimcont/rij
2442 cd              facont_hb(num_conti,i)=1.0D0
2443 C Following line is for diagnostics.
2444 cd              fprimcont=0.0D0
2445                 do k=1,3
2446                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2447                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2448                 enddo
2449                 do k=1,3
2450                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2451                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2452                 enddo
2453                 gggp(1)=gggp(1)+ees0pijp*xj
2454                 gggp(2)=gggp(2)+ees0pijp*yj
2455                 gggp(3)=gggp(3)+ees0pijp*zj
2456                 gggm(1)=gggm(1)+ees0mijp*xj
2457                 gggm(2)=gggm(2)+ees0mijp*yj
2458                 gggm(3)=gggm(3)+ees0mijp*zj
2459 C Derivatives due to the contact function
2460                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2461                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2462                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2463                 do k=1,3
2464                   ghalfp=0.5D0*gggp(k)
2465                   ghalfm=0.5D0*gggm(k)
2466                   gacontp_hb1(k,num_conti,i)=ghalfp
2467      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2468      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2469                   gacontp_hb2(k,num_conti,i)=ghalfp
2470      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2471      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2472                   gacontp_hb3(k,num_conti,i)=gggp(k)
2473                   gacontm_hb1(k,num_conti,i)=ghalfm
2474      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2475      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2476                   gacontm_hb2(k,num_conti,i)=ghalfm
2477      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2478      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2479                   gacontm_hb3(k,num_conti,i)=gggm(k)
2480                 enddo
2481                 endif
2482 C Diagnostics. Comment out or remove after debugging!
2483 cdiag           do k=1,3
2484 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2485 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2486 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2487 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2488 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2489 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2490 cdiag           enddo
2491               ENDIF ! wcorr
2492               endif  ! num_conti.le.maxconts
2493             endif  ! fcont.gt.0
2494           endif    ! j.gt.i+1
2495  1216     continue
2496         enddo ! j
2497         num_cont_hb(i)=num_conti
2498  1215   continue
2499       enddo   ! i
2500 cd      do i=1,nres
2501 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2502 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2503 cd      enddo
2504 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2505 ccc      eel_loc=eel_loc+eello_turn3
2506       return
2507       end
2508 C-----------------------------------------------------------------------------
2509       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2510 C Third- and fourth-order contributions from turns
2511       implicit real*8 (a-h,o-z)
2512       include 'DIMENSIONS'
2513       include 'DIMENSIONS.ZSCOPT'
2514       include 'COMMON.IOUNITS'
2515       include 'COMMON.GEO'
2516       include 'COMMON.VAR'
2517       include 'COMMON.LOCAL'
2518       include 'COMMON.CHAIN'
2519       include 'COMMON.DERIV'
2520       include 'COMMON.INTERACT'
2521       include 'COMMON.CONTACTS'
2522       include 'COMMON.TORSION'
2523       include 'COMMON.VECTORS'
2524       include 'COMMON.FFIELD'
2525       dimension ggg(3)
2526       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2527      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2528      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2529       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2530      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2531       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2532       if (j.eq.i+2) then
2533 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2534 C
2535 C               Third-order contributions
2536 C
2537 C                 (i+2)o----(i+3)
2538 C                      | |
2539 C                      | |
2540 C                 (i+1)o----i
2541 C
2542 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2543 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2544         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2545         call transpose2(auxmat(1,1),auxmat1(1,1))
2546         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2547         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2548 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2549 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2550 cd     &    ' eello_turn3_num',4*eello_turn3_num
2551         if (calc_grad) then
2552 C Derivatives in gamma(i)
2553         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2554         call transpose2(auxmat2(1,1),pizda(1,1))
2555         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2556         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2557 C Derivatives in gamma(i+1)
2558         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2559         call transpose2(auxmat2(1,1),pizda(1,1))
2560         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2561         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2562      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2563 C Cartesian derivatives
2564         do l=1,3
2565           a_temp(1,1)=aggi(l,1)
2566           a_temp(1,2)=aggi(l,2)
2567           a_temp(2,1)=aggi(l,3)
2568           a_temp(2,2)=aggi(l,4)
2569           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2570           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2571      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2572           a_temp(1,1)=aggi1(l,1)
2573           a_temp(1,2)=aggi1(l,2)
2574           a_temp(2,1)=aggi1(l,3)
2575           a_temp(2,2)=aggi1(l,4)
2576           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2577           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2578      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2579           a_temp(1,1)=aggj(l,1)
2580           a_temp(1,2)=aggj(l,2)
2581           a_temp(2,1)=aggj(l,3)
2582           a_temp(2,2)=aggj(l,4)
2583           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2584           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2585      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2586           a_temp(1,1)=aggj1(l,1)
2587           a_temp(1,2)=aggj1(l,2)
2588           a_temp(2,1)=aggj1(l,3)
2589           a_temp(2,2)=aggj1(l,4)
2590           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2591           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2592      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2593         enddo
2594         endif
2595       else if (j.eq.i+3) then
2596 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2597 C
2598 C               Fourth-order contributions
2599 C
2600 C                 (i+3)o----(i+4)
2601 C                     /  |
2602 C               (i+2)o   |
2603 C                     \  |
2604 C                 (i+1)o----i
2605 C
2606 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2607 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2608         iti1=itortyp(itype(i+1))
2609         iti2=itortyp(itype(i+2))
2610         iti3=itortyp(itype(i+3))
2611         call transpose2(EUg(1,1,i+1),e1t(1,1))
2612         call transpose2(Eug(1,1,i+2),e2t(1,1))
2613         call transpose2(Eug(1,1,i+3),e3t(1,1))
2614         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2615         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2616         s1=scalar2(b1(1,iti2),auxvec(1))
2617         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2618         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2619         s2=scalar2(b1(1,iti1),auxvec(1))
2620         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2621         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2622         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2623         eello_turn4=eello_turn4-(s1+s2+s3)
2624 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2625 cd     &    ' eello_turn4_num',8*eello_turn4_num
2626 C Derivatives in gamma(i)
2627         if (calc_grad) then
2628         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2629         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2630         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2631         s1=scalar2(b1(1,iti2),auxvec(1))
2632         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2633         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2634         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2635 C Derivatives in gamma(i+1)
2636         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2637         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2638         s2=scalar2(b1(1,iti1),auxvec(1))
2639         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2640         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2641         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2642         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2643 C Derivatives in gamma(i+2)
2644         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2645         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2646         s1=scalar2(b1(1,iti2),auxvec(1))
2647         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2648         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2649         s2=scalar2(b1(1,iti1),auxvec(1))
2650         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2651         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2652         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2653         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2654 C Cartesian derivatives
2655 C Derivatives of this turn contributions in DC(i+2)
2656         if (j.lt.nres-1) then
2657           do l=1,3
2658             a_temp(1,1)=agg(l,1)
2659             a_temp(1,2)=agg(l,2)
2660             a_temp(2,1)=agg(l,3)
2661             a_temp(2,2)=agg(l,4)
2662             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2663             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2664             s1=scalar2(b1(1,iti2),auxvec(1))
2665             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2666             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2667             s2=scalar2(b1(1,iti1),auxvec(1))
2668             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2669             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2670             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2671             ggg(l)=-(s1+s2+s3)
2672             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2673           enddo
2674         endif
2675 C Remaining derivatives of this turn contribution
2676         do l=1,3
2677           a_temp(1,1)=aggi(l,1)
2678           a_temp(1,2)=aggi(l,2)
2679           a_temp(2,1)=aggi(l,3)
2680           a_temp(2,2)=aggi(l,4)
2681           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2682           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2683           s1=scalar2(b1(1,iti2),auxvec(1))
2684           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2685           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2686           s2=scalar2(b1(1,iti1),auxvec(1))
2687           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2688           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2689           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2690           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2691           a_temp(1,1)=aggi1(l,1)
2692           a_temp(1,2)=aggi1(l,2)
2693           a_temp(2,1)=aggi1(l,3)
2694           a_temp(2,2)=aggi1(l,4)
2695           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2696           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2697           s1=scalar2(b1(1,iti2),auxvec(1))
2698           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2699           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2700           s2=scalar2(b1(1,iti1),auxvec(1))
2701           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2702           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2703           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2704           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2705           a_temp(1,1)=aggj(l,1)
2706           a_temp(1,2)=aggj(l,2)
2707           a_temp(2,1)=aggj(l,3)
2708           a_temp(2,2)=aggj(l,4)
2709           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2710           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2711           s1=scalar2(b1(1,iti2),auxvec(1))
2712           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2713           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2714           s2=scalar2(b1(1,iti1),auxvec(1))
2715           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2716           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2717           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2718           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2719           a_temp(1,1)=aggj1(l,1)
2720           a_temp(1,2)=aggj1(l,2)
2721           a_temp(2,1)=aggj1(l,3)
2722           a_temp(2,2)=aggj1(l,4)
2723           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2724           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2725           s1=scalar2(b1(1,iti2),auxvec(1))
2726           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2727           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2728           s2=scalar2(b1(1,iti1),auxvec(1))
2729           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2730           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2731           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2732           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2733         enddo
2734         endif
2735       endif
2736       return
2737       end
2738 C-----------------------------------------------------------------------------
2739       subroutine vecpr(u,v,w)
2740       implicit real*8(a-h,o-z)
2741       dimension u(3),v(3),w(3)
2742       w(1)=u(2)*v(3)-u(3)*v(2)
2743       w(2)=-u(1)*v(3)+u(3)*v(1)
2744       w(3)=u(1)*v(2)-u(2)*v(1)
2745       return
2746       end
2747 C-----------------------------------------------------------------------------
2748       subroutine unormderiv(u,ugrad,unorm,ungrad)
2749 C This subroutine computes the derivatives of a normalized vector u, given
2750 C the derivatives computed without normalization conditions, ugrad. Returns
2751 C ungrad.
2752       implicit none
2753       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2754       double precision vec(3)
2755       double precision scalar
2756       integer i,j
2757 c      write (2,*) 'ugrad',ugrad
2758 c      write (2,*) 'u',u
2759       do i=1,3
2760         vec(i)=scalar(ugrad(1,i),u(1))
2761       enddo
2762 c      write (2,*) 'vec',vec
2763       do i=1,3
2764         do j=1,3
2765           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2766         enddo
2767       enddo
2768 c      write (2,*) 'ungrad',ungrad
2769       return
2770       end
2771 C-----------------------------------------------------------------------------
2772       subroutine escp(evdw2,evdw2_14)
2773 C
2774 C This subroutine calculates the excluded-volume interaction energy between
2775 C peptide-group centers and side chains and its gradient in virtual-bond and
2776 C side-chain vectors.
2777 C
2778       implicit real*8 (a-h,o-z)
2779       include 'DIMENSIONS'
2780       include 'DIMENSIONS.ZSCOPT'
2781       include 'COMMON.GEO'
2782       include 'COMMON.VAR'
2783       include 'COMMON.LOCAL'
2784       include 'COMMON.CHAIN'
2785       include 'COMMON.DERIV'
2786       include 'COMMON.INTERACT'
2787       include 'COMMON.FFIELD'
2788       include 'COMMON.IOUNITS'
2789       dimension ggg(3)
2790       evdw2=0.0D0
2791       evdw2_14=0.0d0
2792 cd    print '(a)','Enter ESCP'
2793 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
2794 c     &  ' scal14',scal14
2795       do i=iatscp_s,iatscp_e
2796         iteli=itel(i)
2797 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
2798 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
2799         if (iteli.eq.0) goto 1225
2800         xi=0.5D0*(c(1,i)+c(1,i+1))
2801         yi=0.5D0*(c(2,i)+c(2,i+1))
2802         zi=0.5D0*(c(3,i)+c(3,i+1))
2803
2804         do iint=1,nscp_gr(i)
2805
2806         do j=iscpstart(i,iint),iscpend(i,iint)
2807           itypj=itype(j)
2808 C Uncomment following three lines for SC-p interactions
2809 c         xj=c(1,nres+j)-xi
2810 c         yj=c(2,nres+j)-yi
2811 c         zj=c(3,nres+j)-zi
2812 C Uncomment following three lines for Ca-p interactions
2813           xj=c(1,j)-xi
2814           yj=c(2,j)-yi
2815           zj=c(3,j)-zi
2816           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2817           fac=rrij**expon2
2818           e1=fac*fac*aad(itypj,iteli)
2819           e2=fac*bad(itypj,iteli)
2820           if (iabs(j-i) .le. 2) then
2821             e1=scal14*e1
2822             e2=scal14*e2
2823             evdw2_14=evdw2_14+e1+e2
2824           endif
2825           evdwij=e1+e2
2826 c          write (iout,*) i,j,evdwij
2827           evdw2=evdw2+evdwij
2828           if (calc_grad) then
2829 C
2830 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2831 C
2832           fac=-(evdwij+e1)*rrij
2833           ggg(1)=xj*fac
2834           ggg(2)=yj*fac
2835           ggg(3)=zj*fac
2836           if (j.lt.i) then
2837 cd          write (iout,*) 'j<i'
2838 C Uncomment following three lines for SC-p interactions
2839 c           do k=1,3
2840 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2841 c           enddo
2842           else
2843 cd          write (iout,*) 'j>i'
2844             do k=1,3
2845               ggg(k)=-ggg(k)
2846 C Uncomment following line for SC-p interactions
2847 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2848             enddo
2849           endif
2850           do k=1,3
2851             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2852           enddo
2853           kstart=min0(i+1,j)
2854           kend=max0(i-1,j-1)
2855 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2856 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2857           do k=kstart,kend
2858             do l=1,3
2859               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2860             enddo
2861           enddo
2862           endif
2863         enddo
2864         enddo ! iint
2865  1225   continue
2866       enddo ! i
2867       do i=1,nct
2868         do j=1,3
2869           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2870           gradx_scp(j,i)=expon*gradx_scp(j,i)
2871         enddo
2872       enddo
2873 C******************************************************************************
2874 C
2875 C                              N O T E !!!
2876 C
2877 C To save time the factor EXPON has been extracted from ALL components
2878 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2879 C use!
2880 C
2881 C******************************************************************************
2882       return
2883       end
2884 C--------------------------------------------------------------------------
2885       subroutine edis(ehpb)
2886 C
2887 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2888 C
2889       implicit real*8 (a-h,o-z)
2890       include 'DIMENSIONS'
2891       include 'COMMON.SBRIDGE'
2892       include 'COMMON.CHAIN'
2893       include 'COMMON.DERIV'
2894       include 'COMMON.VAR'
2895       include 'COMMON.INTERACT'
2896       include 'COMMON.IOUNITS'
2897       dimension ggg(3)
2898       ehpb=0.0D0
2899 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
2900 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
2901       if (link_end.eq.0) return
2902       do i=link_start,link_end
2903 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2904 C CA-CA distance used in regularization of structure.
2905         ii=ihpb(i)
2906         jj=jhpb(i)
2907 C iii and jjj point to the residues for which the distance is assigned.
2908         if (ii.gt.nres) then
2909           iii=ii-nres
2910           jjj=jj-nres
2911         else
2912           iii=ii
2913           jjj=jj
2914         endif
2915 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
2916 c     &    dhpb(i),dhpb1(i),forcon(i)
2917 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2918 C    distance and angle dependent SS bond potential.
2919         if (.not.dyn_ss .and. i.le.nss) then
2920 C 15/02/13 CC dynamic SSbond - additional check
2921         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2922           call ssbond_ene(iii,jjj,eij)
2923           ehpb=ehpb+2*eij
2924          endif
2925 cd          write (iout,*) "eij",eij
2926         else if (ii.gt.nres .and. jj.gt.nres) then
2927 c Restraints from contact prediction
2928           dd=dist(ii,jj)
2929           if (dhpb1(i).gt.0.0d0) then
2930             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2931             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2932 c            write (iout,*) "beta nmr",
2933 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2934           else
2935             dd=dist(ii,jj)
2936             rdis=dd-dhpb(i)
2937 C Get the force constant corresponding to this distance.
2938             waga=forcon(i)
2939 C Calculate the contribution to energy.
2940             ehpb=ehpb+waga*rdis*rdis
2941 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
2942 C
2943 C Evaluate gradient.
2944 C
2945             fac=waga*rdis/dd
2946           endif
2947           do j=1,3
2948             ggg(j)=fac*(c(j,jj)-c(j,ii))
2949           enddo
2950           do j=1,3
2951             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2952             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2953           enddo
2954           do k=1,3
2955             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
2956             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
2957           enddo
2958         else
2959 C Calculate the distance between the two points and its difference from the
2960 C target distance.
2961           dd=dist(ii,jj)
2962           if (dhpb1(i).gt.0.0d0) then
2963             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2964             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
2965 c            write (iout,*) "alph nmr",
2966 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
2967           else
2968             rdis=dd-dhpb(i)
2969 C Get the force constant corresponding to this distance.
2970             waga=forcon(i)
2971 C Calculate the contribution to energy.
2972             ehpb=ehpb+waga*rdis*rdis
2973 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
2974 C
2975 C Evaluate gradient.
2976 C
2977             fac=waga*rdis/dd
2978           endif
2979 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
2980 cd   &   ' waga=',waga,' fac=',fac
2981             do j=1,3
2982               ggg(j)=fac*(c(j,jj)-c(j,ii))
2983             enddo
2984 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
2985 C If this is a SC-SC distance, we need to calculate the contributions to the
2986 C Cartesian gradient in the SC vectors (ghpbx).
2987           if (iii.lt.ii) then
2988           do j=1,3
2989             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2990             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2991           enddo
2992           endif
2993           do k=1,3
2994             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
2995             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
2996           enddo
2997         endif
2998       enddo
2999       ehpb=0.5D0*ehpb
3000       return
3001       end
3002 C--------------------------------------------------------------------------
3003       subroutine ssbond_ene(i,j,eij)
3004 C
3005 C Calculate the distance and angle dependent SS-bond potential energy
3006 C using a free-energy function derived based on RHF/6-31G** ab initio
3007 C calculations of diethyl disulfide.
3008 C
3009 C A. Liwo and U. Kozlowska, 11/24/03
3010 C
3011       implicit real*8 (a-h,o-z)
3012       include 'DIMENSIONS'
3013       include 'DIMENSIONS.ZSCOPT'
3014       include 'COMMON.SBRIDGE'
3015       include 'COMMON.CHAIN'
3016       include 'COMMON.DERIV'
3017       include 'COMMON.LOCAL'
3018       include 'COMMON.INTERACT'
3019       include 'COMMON.VAR'
3020       include 'COMMON.IOUNITS'
3021       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3022       itypi=itype(i)
3023       xi=c(1,nres+i)
3024       yi=c(2,nres+i)
3025       zi=c(3,nres+i)
3026       dxi=dc_norm(1,nres+i)
3027       dyi=dc_norm(2,nres+i)
3028       dzi=dc_norm(3,nres+i)
3029       dsci_inv=dsc_inv(itypi)
3030       itypj=itype(j)
3031       dscj_inv=dsc_inv(itypj)
3032       xj=c(1,nres+j)-xi
3033       yj=c(2,nres+j)-yi
3034       zj=c(3,nres+j)-zi
3035       dxj=dc_norm(1,nres+j)
3036       dyj=dc_norm(2,nres+j)
3037       dzj=dc_norm(3,nres+j)
3038       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3039       rij=dsqrt(rrij)
3040       erij(1)=xj*rij
3041       erij(2)=yj*rij
3042       erij(3)=zj*rij
3043       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3044       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3045       om12=dxi*dxj+dyi*dyj+dzi*dzj
3046       do k=1,3
3047         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3048         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3049       enddo
3050       rij=1.0d0/rij
3051       deltad=rij-d0cm
3052       deltat1=1.0d0-om1
3053       deltat2=1.0d0+om2
3054       deltat12=om2-om1+2.0d0
3055       cosphi=om12-om1*om2
3056       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3057      &  +akct*deltad*deltat12+ebr
3058 c     &  +akct*deltad*deltat12
3059      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3060       write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3061      &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3062      &  " deltat12",deltat12," eij",eij,"ebr",ebr
3063       ed=2*akcm*deltad+akct*deltat12
3064       pom1=akct*deltad
3065       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3066       eom1=-2*akth*deltat1-pom1-om2*pom2
3067       eom2= 2*akth*deltat2+pom1-om1*pom2
3068       eom12=pom2
3069       do k=1,3
3070         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3071       enddo
3072       do k=1,3
3073         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3074      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3075         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3076      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3077       enddo
3078 C
3079 C Calculate the components of the gradient in DC and X
3080 C
3081       do k=i,j-1
3082         do l=1,3
3083           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3084         enddo
3085       enddo
3086       return
3087       end
3088 C--------------------------------------------------------------------------
3089       subroutine ebond(estr)
3090 c
3091 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3092 c
3093       implicit real*8 (a-h,o-z)
3094       include 'DIMENSIONS'
3095       include 'DIMENSIONS.ZSCOPT'
3096       include 'COMMON.LOCAL'
3097       include 'COMMON.GEO'
3098       include 'COMMON.INTERACT'
3099       include 'COMMON.DERIV'
3100       include 'COMMON.VAR'
3101       include 'COMMON.CHAIN'
3102       include 'COMMON.IOUNITS'
3103       include 'COMMON.NAMES'
3104       include 'COMMON.FFIELD'
3105       include 'COMMON.CONTROL'
3106       double precision u(3),ud(3)
3107       logical :: lprn=.false.
3108       estr=0.0d0
3109       do i=nnt+1,nct
3110         diff = vbld(i)-vbldp0
3111 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3112         estr=estr+diff*diff
3113         do j=1,3
3114           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3115         enddo
3116       enddo
3117       estr=0.5d0*AKP*estr
3118 c
3119 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3120 c
3121       do i=nnt,nct
3122         iti=itype(i)
3123         if (iti.ne.10) then
3124           nbi=nbondterm(iti)
3125           if (nbi.eq.1) then
3126             diff=vbld(i+nres)-vbldsc0(1,iti)
3127             if (lprn)
3128      &      write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3129      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3130             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3131             do j=1,3
3132               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3133             enddo
3134           else
3135             do j=1,nbi
3136               diff=vbld(i+nres)-vbldsc0(j,iti)
3137               ud(j)=aksc(j,iti)*diff
3138               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3139             enddo
3140             uprod=u(1)
3141             do j=2,nbi
3142               uprod=uprod*u(j)
3143             enddo
3144             usum=0.0d0
3145             usumsqder=0.0d0
3146             do j=1,nbi
3147               uprod1=1.0d0
3148               uprod2=1.0d0
3149               do k=1,nbi
3150                 if (k.ne.j) then
3151                   uprod1=uprod1*u(k)
3152                   uprod2=uprod2*u(k)*u(k)
3153                 endif
3154               enddo
3155               usum=usum+uprod1
3156               usumsqder=usumsqder+ud(j)*uprod2
3157             enddo
3158             if (lprn)
3159      &      write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
3160      &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
3161             estr=estr+uprod/usum
3162             do j=1,3
3163              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3164             enddo
3165           endif
3166         endif
3167       enddo
3168       return
3169       end
3170 #ifdef CRYST_THETA
3171 C--------------------------------------------------------------------------
3172       subroutine ebend(etheta)
3173 C
3174 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3175 C angles gamma and its derivatives in consecutive thetas and gammas.
3176 C
3177       implicit real*8 (a-h,o-z)
3178       include 'DIMENSIONS'
3179       include 'DIMENSIONS.ZSCOPT'
3180       include 'COMMON.LOCAL'
3181       include 'COMMON.GEO'
3182       include 'COMMON.INTERACT'
3183       include 'COMMON.DERIV'
3184       include 'COMMON.VAR'
3185       include 'COMMON.CHAIN'
3186       include 'COMMON.IOUNITS'
3187       include 'COMMON.NAMES'
3188       include 'COMMON.FFIELD'
3189       common /calcthet/ term1,term2,termm,diffak,ratak,
3190      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3191      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3192       double precision y(2),z(2)
3193       delta=0.02d0*pi
3194       time11=dexp(-2*time)
3195       time12=1.0d0
3196       etheta=0.0D0
3197 c      write (iout,*) "nres",nres
3198 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3199 c      write (iout,*) ithet_start,ithet_end
3200       do i=ithet_start,ithet_end
3201 C Zero the energy function and its derivative at 0 or pi.
3202         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3203         it=itype(i-1)
3204 c        if (i.gt.ithet_start .and.
3205 c     &     (itel(i-1).eq.0 .or. itel(i-2).eq.0)) goto 1215
3206 c        if (i.gt.3 .and. (i.le.4 .or. itel(i-3).ne.0)) then
3207 c          phii=phi(i)
3208 c          y(1)=dcos(phii)
3209 c          y(2)=dsin(phii)
3210 c        else
3211 c          y(1)=0.0D0
3212 c          y(2)=0.0D0
3213 c        endif
3214 c        if (i.lt.nres .and. itel(i).ne.0) then
3215 c          phii1=phi(i+1)
3216 c          z(1)=dcos(phii1)
3217 c          z(2)=dsin(phii1)
3218 c        else
3219 c          z(1)=0.0D0
3220 c          z(2)=0.0D0
3221 c        endif
3222         if (i.gt.3) then
3223 #ifdef OSF
3224           phii=phi(i)
3225           icrc=0
3226           call proc_proc(phii,icrc)
3227           if (icrc.eq.1) phii=150.0
3228 #else
3229           phii=phi(i)
3230 #endif
3231           y(1)=dcos(phii)
3232           y(2)=dsin(phii)
3233         else
3234           y(1)=0.0D0
3235           y(2)=0.0D0
3236         endif
3237         if (i.lt.nres) then
3238 #ifdef OSF
3239           phii1=phi(i+1)
3240           icrc=0
3241           call proc_proc(phii1,icrc)
3242           if (icrc.eq.1) phii1=150.0
3243           phii1=pinorm(phii1)
3244           z(1)=cos(phii1)
3245 #else
3246           phii1=phi(i+1)
3247           z(1)=dcos(phii1)
3248 #endif
3249           z(2)=dsin(phii1)
3250         else
3251           z(1)=0.0D0
3252           z(2)=0.0D0
3253         endif
3254 C Calculate the "mean" value of theta from the part of the distribution
3255 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3256 C In following comments this theta will be referred to as t_c.
3257         thet_pred_mean=0.0d0
3258         do k=1,2
3259           athetk=athet(k,it)
3260           bthetk=bthet(k,it)
3261           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3262         enddo
3263 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3264         dthett=thet_pred_mean*ssd
3265         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3266 c        write (iout,*) "thet_pred_mean",thet_pred_mean
3267 C Derivatives of the "mean" values in gamma1 and gamma2.
3268         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3269         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3270         if (theta(i).gt.pi-delta) then
3271           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3272      &         E_tc0)
3273           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3274           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3275           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3276      &        E_theta)
3277           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3278      &        E_tc)
3279         else if (theta(i).lt.delta) then
3280           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3281           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3282           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3283      &        E_theta)
3284           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3285           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3286      &        E_tc)
3287         else
3288           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3289      &        E_theta,E_tc)
3290         endif
3291         etheta=etheta+ethetai
3292 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
3293 c     &    rad2deg*phii,rad2deg*phii1,ethetai
3294         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3295         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3296         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3297  1215   continue
3298       enddo
3299 C Ufff.... We've done all this!!!
3300       return
3301       end
3302 C---------------------------------------------------------------------------
3303       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3304      &     E_tc)
3305       implicit real*8 (a-h,o-z)
3306       include 'DIMENSIONS'
3307       include 'COMMON.LOCAL'
3308       include 'COMMON.IOUNITS'
3309       common /calcthet/ term1,term2,termm,diffak,ratak,
3310      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3311      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3312 C Calculate the contributions to both Gaussian lobes.
3313 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3314 C The "polynomial part" of the "standard deviation" of this part of
3315 C the distribution.
3316         sig=polthet(3,it)
3317         do j=2,0,-1
3318           sig=sig*thet_pred_mean+polthet(j,it)
3319         enddo
3320 C Derivative of the "interior part" of the "standard deviation of the"
3321 C gamma-dependent Gaussian lobe in t_c.
3322         sigtc=3*polthet(3,it)
3323         do j=2,1,-1
3324           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3325         enddo
3326         sigtc=sig*sigtc
3327 C Set the parameters of both Gaussian lobes of the distribution.
3328 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3329         fac=sig*sig+sigc0(it)
3330         sigcsq=fac+fac
3331         sigc=1.0D0/sigcsq
3332 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3333         sigsqtc=-4.0D0*sigcsq*sigtc
3334 c       print *,i,sig,sigtc,sigsqtc
3335 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3336         sigtc=-sigtc/(fac*fac)
3337 C Following variable is sigma(t_c)**(-2)
3338         sigcsq=sigcsq*sigcsq
3339         sig0i=sig0(it)
3340         sig0inv=1.0D0/sig0i**2
3341         delthec=thetai-thet_pred_mean
3342         delthe0=thetai-theta0i
3343         term1=-0.5D0*sigcsq*delthec*delthec
3344         term2=-0.5D0*sig0inv*delthe0*delthe0
3345 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3346 C NaNs in taking the logarithm. We extract the largest exponent which is added
3347 C to the energy (this being the log of the distribution) at the end of energy
3348 C term evaluation for this virtual-bond angle.
3349         if (term1.gt.term2) then
3350           termm=term1
3351           term2=dexp(term2-termm)
3352           term1=1.0d0
3353         else
3354           termm=term2
3355           term1=dexp(term1-termm)
3356           term2=1.0d0
3357         endif
3358 C The ratio between the gamma-independent and gamma-dependent lobes of
3359 C the distribution is a Gaussian function of thet_pred_mean too.
3360         diffak=gthet(2,it)-thet_pred_mean
3361         ratak=diffak/gthet(3,it)**2
3362         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3363 C Let's differentiate it in thet_pred_mean NOW.
3364         aktc=ak*ratak
3365 C Now put together the distribution terms to make complete distribution.
3366         termexp=term1+ak*term2
3367         termpre=sigc+ak*sig0i
3368 C Contribution of the bending energy from this theta is just the -log of
3369 C the sum of the contributions from the two lobes and the pre-exponential
3370 C factor. Simple enough, isn't it?
3371         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3372 C NOW the derivatives!!!
3373 C 6/6/97 Take into account the deformation.
3374         E_theta=(delthec*sigcsq*term1
3375      &       +ak*delthe0*sig0inv*term2)/termexp
3376         E_tc=((sigtc+aktc*sig0i)/termpre
3377      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3378      &       aktc*term2)/termexp)
3379       return
3380       end
3381 c-----------------------------------------------------------------------------
3382       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3383       implicit real*8 (a-h,o-z)
3384       include 'DIMENSIONS'
3385       include 'COMMON.LOCAL'
3386       include 'COMMON.IOUNITS'
3387       common /calcthet/ term1,term2,termm,diffak,ratak,
3388      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3389      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3390       delthec=thetai-thet_pred_mean
3391       delthe0=thetai-theta0i
3392 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
3393       t3 = thetai-thet_pred_mean
3394       t6 = t3**2
3395       t9 = term1
3396       t12 = t3*sigcsq
3397       t14 = t12+t6*sigsqtc
3398       t16 = 1.0d0
3399       t21 = thetai-theta0i
3400       t23 = t21**2
3401       t26 = term2
3402       t27 = t21*t26
3403       t32 = termexp
3404       t40 = t32**2
3405       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
3406      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
3407      & *(-t12*t9-ak*sig0inv*t27)
3408       return
3409       end
3410 #else
3411 C--------------------------------------------------------------------------
3412       subroutine ebend(etheta)
3413 C
3414 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3415 C angles gamma and its derivatives in consecutive thetas and gammas.
3416 C ab initio-derived potentials from
3417 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
3418 C
3419       implicit real*8 (a-h,o-z)
3420       include 'DIMENSIONS'
3421       include 'DIMENSIONS.ZSCOPT'
3422       include 'COMMON.LOCAL'
3423       include 'COMMON.GEO'
3424       include 'COMMON.INTERACT'
3425       include 'COMMON.DERIV'
3426       include 'COMMON.VAR'
3427       include 'COMMON.CHAIN'
3428       include 'COMMON.IOUNITS'
3429       include 'COMMON.NAMES'
3430       include 'COMMON.FFIELD'
3431       include 'COMMON.CONTROL'
3432       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
3433      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
3434      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
3435      & sinph1ph2(maxdouble,maxdouble)
3436       logical lprn /.false./, lprn1 /.false./
3437       etheta=0.0D0
3438 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
3439       do i=ithet_start,ithet_end
3440         dethetai=0.0d0
3441         dephii=0.0d0
3442         dephii1=0.0d0
3443         theti2=0.5d0*theta(i)
3444         ityp2=ithetyp(itype(i-1))
3445         do k=1,nntheterm
3446           coskt(k)=dcos(k*theti2)
3447           sinkt(k)=dsin(k*theti2)
3448         enddo
3449         if (i.gt.3) then
3450 #ifdef OSF
3451           phii=phi(i)
3452           if (phii.ne.phii) phii=150.0
3453 #else
3454           phii=phi(i)
3455 #endif
3456           ityp1=ithetyp(itype(i-2))
3457           do k=1,nsingle
3458             cosph1(k)=dcos(k*phii)
3459             sinph1(k)=dsin(k*phii)
3460           enddo
3461         else
3462           phii=0.0d0
3463           ityp1=nthetyp+1
3464           do k=1,nsingle
3465             cosph1(k)=0.0d0
3466             sinph1(k)=0.0d0
3467           enddo
3468         endif
3469         if (i.lt.nres) then
3470 #ifdef OSF
3471           phii1=phi(i+1)
3472           if (phii1.ne.phii1) phii1=150.0
3473           phii1=pinorm(phii1)
3474 #else
3475           phii1=phi(i+1)
3476 #endif
3477           ityp3=ithetyp(itype(i))
3478           do k=1,nsingle
3479             cosph2(k)=dcos(k*phii1)
3480             sinph2(k)=dsin(k*phii1)
3481           enddo
3482         else
3483           phii1=0.0d0
3484           ityp3=nthetyp+1
3485           do k=1,nsingle
3486             cosph2(k)=0.0d0
3487             sinph2(k)=0.0d0
3488           enddo
3489         endif
3490 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
3491 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
3492 c        call flush(iout)
3493         ethetai=aa0thet(ityp1,ityp2,ityp3)
3494         do k=1,ndouble
3495           do l=1,k-1
3496             ccl=cosph1(l)*cosph2(k-l)
3497             ssl=sinph1(l)*sinph2(k-l)
3498             scl=sinph1(l)*cosph2(k-l)
3499             csl=cosph1(l)*sinph2(k-l)
3500             cosph1ph2(l,k)=ccl-ssl
3501             cosph1ph2(k,l)=ccl+ssl
3502             sinph1ph2(l,k)=scl+csl
3503             sinph1ph2(k,l)=scl-csl
3504           enddo
3505         enddo
3506         if (lprn) then
3507         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
3508      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
3509         write (iout,*) "coskt and sinkt"
3510         do k=1,nntheterm
3511           write (iout,*) k,coskt(k),sinkt(k)
3512         enddo
3513         endif
3514         do k=1,ntheterm
3515           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
3516           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
3517      &      *coskt(k)
3518           if (lprn)
3519      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
3520      &     " ethetai",ethetai
3521         enddo
3522         if (lprn) then
3523         write (iout,*) "cosph and sinph"
3524         do k=1,nsingle
3525           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
3526         enddo
3527         write (iout,*) "cosph1ph2 and sinph2ph2"
3528         do k=2,ndouble
3529           do l=1,k-1
3530             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
3531      &         sinph1ph2(l,k),sinph1ph2(k,l)
3532           enddo
3533         enddo
3534         write(iout,*) "ethetai",ethetai
3535         endif
3536         do m=1,ntheterm2
3537           do k=1,nsingle
3538             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
3539      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
3540      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
3541      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
3542             ethetai=ethetai+sinkt(m)*aux
3543             dethetai=dethetai+0.5d0*m*aux*coskt(m)
3544             dephii=dephii+k*sinkt(m)*(
3545      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
3546      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
3547             dephii1=dephii1+k*sinkt(m)*(
3548      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
3549      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
3550             if (lprn)
3551      &      write (iout,*) "m",m," k",k," bbthet",
3552      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
3553      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
3554      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
3555      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3556           enddo
3557         enddo
3558         if (lprn)
3559      &  write(iout,*) "ethetai",ethetai
3560         do m=1,ntheterm3
3561           do k=2,ndouble
3562             do l=1,k-1
3563               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3564      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
3565      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3566      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
3567               ethetai=ethetai+sinkt(m)*aux
3568               dethetai=dethetai+0.5d0*m*coskt(m)*aux
3569               dephii=dephii+l*sinkt(m)*(
3570      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
3571      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3572      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3573      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3574               dephii1=dephii1+(k-l)*sinkt(m)*(
3575      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3576      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3577      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
3578      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3579               if (lprn) then
3580               write (iout,*) "m",m," k",k," l",l," ffthet",
3581      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
3582      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
3583      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
3584      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3585               write (iout,*) cosph1ph2(l,k)*sinkt(m),
3586      &            cosph1ph2(k,l)*sinkt(m),
3587      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
3588               endif
3589             enddo
3590           enddo
3591         enddo
3592 10      continue
3593 c        lprn1=.true.
3594         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
3595      &  'ebe',i,theta(i)*rad2deg,phii*rad2deg,
3596      &   phii1*rad2deg,ethetai
3597 c        lprn1=.false.
3598         etheta=etheta+ethetai
3599
3600         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
3601         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
3602         gloc(nphi+i-2,icg)=wang*dethetai
3603       enddo
3604       return
3605       end
3606 #endif
3607 #ifdef CRYST_SC
3608 c-----------------------------------------------------------------------------
3609       subroutine esc(escloc)
3610 C Calculate the local energy of a side chain and its derivatives in the
3611 C corresponding virtual-bond valence angles THETA and the spherical angles
3612 C ALPHA and OMEGA.
3613       implicit real*8 (a-h,o-z)
3614       include 'DIMENSIONS'
3615       include 'DIMENSIONS.ZSCOPT'
3616       include 'COMMON.GEO'
3617       include 'COMMON.LOCAL'
3618       include 'COMMON.VAR'
3619       include 'COMMON.INTERACT'
3620       include 'COMMON.DERIV'
3621       include 'COMMON.CHAIN'
3622       include 'COMMON.IOUNITS'
3623       include 'COMMON.NAMES'
3624       include 'COMMON.FFIELD'
3625       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
3626      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
3627       common /sccalc/ time11,time12,time112,theti,it,nlobit
3628       delta=0.02d0*pi
3629       escloc=0.0D0
3630 c     write (iout,'(a)') 'ESC'
3631       do i=loc_start,loc_end
3632         it=itype(i)
3633         if (it.eq.10) goto 1
3634         nlobit=nlob(it)
3635 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
3636 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
3637         theti=theta(i+1)-pipol
3638         x(1)=dtan(theti)
3639         x(2)=alph(i)
3640         x(3)=omeg(i)
3641 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
3642
3643         if (x(2).gt.pi-delta) then
3644           xtemp(1)=x(1)
3645           xtemp(2)=pi-delta
3646           xtemp(3)=x(3)
3647           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3648           xtemp(2)=pi
3649           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3650           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
3651      &        escloci,dersc(2))
3652           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3653      &        ddersc0(1),dersc(1))
3654           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
3655      &        ddersc0(3),dersc(3))
3656           xtemp(2)=pi-delta
3657           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3658           xtemp(2)=pi
3659           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3660           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
3661      &            dersc0(2),esclocbi,dersc02)
3662           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3663      &            dersc12,dersc01)
3664           call splinthet(x(2),0.5d0*delta,ss,ssd)
3665           dersc0(1)=dersc01
3666           dersc0(2)=dersc02
3667           dersc0(3)=0.0d0
3668           do k=1,3
3669             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3670           enddo
3671           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3672 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3673 c    &             esclocbi,ss,ssd
3674           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3675 c         escloci=esclocbi
3676 c         write (iout,*) escloci
3677         else if (x(2).lt.delta) then
3678           xtemp(1)=x(1)
3679           xtemp(2)=delta
3680           xtemp(3)=x(3)
3681           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3682           xtemp(2)=0.0d0
3683           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3684           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
3685      &        escloci,dersc(2))
3686           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3687      &        ddersc0(1),dersc(1))
3688           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
3689      &        ddersc0(3),dersc(3))
3690           xtemp(2)=delta
3691           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3692           xtemp(2)=0.0d0
3693           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3694           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
3695      &            dersc0(2),esclocbi,dersc02)
3696           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3697      &            dersc12,dersc01)
3698           dersc0(1)=dersc01
3699           dersc0(2)=dersc02
3700           dersc0(3)=0.0d0
3701           call splinthet(x(2),0.5d0*delta,ss,ssd)
3702           do k=1,3
3703             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3704           enddo
3705           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3706 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3707 c    &             esclocbi,ss,ssd
3708           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3709 c         write (iout,*) escloci
3710         else
3711           call enesc(x,escloci,dersc,ddummy,.false.)
3712         endif
3713
3714         escloc=escloc+escloci
3715 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
3716
3717         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3718      &   wscloc*dersc(1)
3719         gloc(ialph(i,1),icg)=wscloc*dersc(2)
3720         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
3721     1   continue
3722       enddo
3723       return
3724       end
3725 C---------------------------------------------------------------------------
3726       subroutine enesc(x,escloci,dersc,ddersc,mixed)
3727       implicit real*8 (a-h,o-z)
3728       include 'DIMENSIONS'
3729       include 'COMMON.GEO'
3730       include 'COMMON.LOCAL'
3731       include 'COMMON.IOUNITS'
3732       common /sccalc/ time11,time12,time112,theti,it,nlobit
3733       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
3734       double precision contr(maxlob,-1:1)
3735       logical mixed
3736 c       write (iout,*) 'it=',it,' nlobit=',nlobit
3737         escloc_i=0.0D0
3738         do j=1,3
3739           dersc(j)=0.0D0
3740           if (mixed) ddersc(j)=0.0d0
3741         enddo
3742         x3=x(3)
3743
3744 C Because of periodicity of the dependence of the SC energy in omega we have
3745 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
3746 C To avoid underflows, first compute & store the exponents.
3747
3748         do iii=-1,1
3749
3750           x(3)=x3+iii*dwapi
3751
3752           do j=1,nlobit
3753             do k=1,3
3754               z(k)=x(k)-censc(k,j,it)
3755             enddo
3756             do k=1,3
3757               Axk=0.0D0
3758               do l=1,3
3759                 Axk=Axk+gaussc(l,k,j,it)*z(l)
3760               enddo
3761               Ax(k,j,iii)=Axk
3762             enddo
3763             expfac=0.0D0
3764             do k=1,3
3765               expfac=expfac+Ax(k,j,iii)*z(k)
3766             enddo
3767             contr(j,iii)=expfac
3768           enddo ! j
3769
3770         enddo ! iii
3771
3772         x(3)=x3
3773 C As in the case of ebend, we want to avoid underflows in exponentiation and
3774 C subsequent NaNs and INFs in energy calculation.
3775 C Find the largest exponent
3776         emin=contr(1,-1)
3777         do iii=-1,1
3778           do j=1,nlobit
3779             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
3780           enddo
3781         enddo
3782         emin=0.5D0*emin
3783 cd      print *,'it=',it,' emin=',emin
3784
3785 C Compute the contribution to SC energy and derivatives
3786         do iii=-1,1
3787
3788           do j=1,nlobit
3789             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
3790 cd          print *,'j=',j,' expfac=',expfac
3791             escloc_i=escloc_i+expfac
3792             do k=1,3
3793               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
3794             enddo
3795             if (mixed) then
3796               do k=1,3,2
3797                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
3798      &            +gaussc(k,2,j,it))*expfac
3799               enddo
3800             endif
3801           enddo
3802
3803         enddo ! iii
3804
3805         dersc(1)=dersc(1)/cos(theti)**2
3806         ddersc(1)=ddersc(1)/cos(theti)**2
3807         ddersc(3)=ddersc(3)
3808
3809         escloci=-(dlog(escloc_i)-emin)
3810         do j=1,3
3811           dersc(j)=dersc(j)/escloc_i
3812         enddo
3813         if (mixed) then
3814           do j=1,3,2
3815             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
3816           enddo
3817         endif
3818       return
3819       end
3820 C------------------------------------------------------------------------------
3821       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
3822       implicit real*8 (a-h,o-z)
3823       include 'DIMENSIONS'
3824       include 'COMMON.GEO'
3825       include 'COMMON.LOCAL'
3826       include 'COMMON.IOUNITS'
3827       common /sccalc/ time11,time12,time112,theti,it,nlobit
3828       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
3829       double precision contr(maxlob)
3830       logical mixed
3831
3832       escloc_i=0.0D0
3833
3834       do j=1,3
3835         dersc(j)=0.0D0
3836       enddo
3837
3838       do j=1,nlobit
3839         do k=1,2
3840           z(k)=x(k)-censc(k,j,it)
3841         enddo
3842         z(3)=dwapi
3843         do k=1,3
3844           Axk=0.0D0
3845           do l=1,3
3846             Axk=Axk+gaussc(l,k,j,it)*z(l)
3847           enddo
3848           Ax(k,j)=Axk
3849         enddo
3850         expfac=0.0D0
3851         do k=1,3
3852           expfac=expfac+Ax(k,j)*z(k)
3853         enddo
3854         contr(j)=expfac
3855       enddo ! j
3856
3857 C As in the case of ebend, we want to avoid underflows in exponentiation and
3858 C subsequent NaNs and INFs in energy calculation.
3859 C Find the largest exponent
3860       emin=contr(1)
3861       do j=1,nlobit
3862         if (emin.gt.contr(j)) emin=contr(j)
3863       enddo
3864       emin=0.5D0*emin
3865
3866 C Compute the contribution to SC energy and derivatives
3867
3868       dersc12=0.0d0
3869       do j=1,nlobit
3870         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
3871         escloc_i=escloc_i+expfac
3872         do k=1,2
3873           dersc(k)=dersc(k)+Ax(k,j)*expfac
3874         enddo
3875         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
3876      &            +gaussc(1,2,j,it))*expfac
3877         dersc(3)=0.0d0
3878       enddo
3879
3880       dersc(1)=dersc(1)/cos(theti)**2
3881       dersc12=dersc12/cos(theti)**2
3882       escloci=-(dlog(escloc_i)-emin)
3883       do j=1,2
3884         dersc(j)=dersc(j)/escloc_i
3885       enddo
3886       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
3887       return
3888       end
3889 #else
3890 c----------------------------------------------------------------------------------
3891       subroutine esc(escloc)
3892 C Calculate the local energy of a side chain and its derivatives in the
3893 C corresponding virtual-bond valence angles THETA and the spherical angles
3894 C ALPHA and OMEGA derived from AM1 all-atom calculations.
3895 C added by Urszula Kozlowska. 07/11/2007
3896 C
3897       implicit real*8 (a-h,o-z)
3898       include 'DIMENSIONS'
3899       include 'DIMENSIONS.ZSCOPT'
3900       include 'COMMON.GEO'
3901       include 'COMMON.LOCAL'
3902       include 'COMMON.VAR'
3903       include 'COMMON.SCROT'
3904       include 'COMMON.INTERACT'
3905       include 'COMMON.DERIV'
3906       include 'COMMON.CHAIN'
3907       include 'COMMON.IOUNITS'
3908       include 'COMMON.NAMES'
3909       include 'COMMON.FFIELD'
3910       include 'COMMON.CONTROL'
3911       include 'COMMON.VECTORS'
3912       double precision x_prime(3),y_prime(3),z_prime(3)
3913      &    , sumene,dsc_i,dp2_i,x(65),
3914      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
3915      &    de_dxx,de_dyy,de_dzz,de_dt
3916       double precision s1_t,s1_6_t,s2_t,s2_6_t
3917       double precision
3918      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
3919      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
3920      & dt_dCi(3),dt_dCi1(3)
3921       common /sccalc/ time11,time12,time112,theti,it,nlobit
3922       delta=0.02d0*pi
3923       escloc=0.0D0
3924       do i=loc_start,loc_end
3925         costtab(i+1) =dcos(theta(i+1))
3926         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
3927         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
3928         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
3929         cosfac2=0.5d0/(1.0d0+costtab(i+1))
3930         cosfac=dsqrt(cosfac2)
3931         sinfac2=0.5d0/(1.0d0-costtab(i+1))
3932         sinfac=dsqrt(sinfac2)
3933         it=itype(i)
3934         if (it.eq.10) goto 1
3935 c
3936 C  Compute the axes of tghe local cartesian coordinates system; store in
3937 c   x_prime, y_prime and z_prime
3938 c
3939         do j=1,3
3940           x_prime(j) = 0.00
3941           y_prime(j) = 0.00
3942           z_prime(j) = 0.00
3943         enddo
3944 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
3945 C     &   dc_norm(3,i+nres)
3946         do j = 1,3
3947           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
3948           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
3949         enddo
3950         do j = 1,3
3951           z_prime(j) = -uz(j,i-1)
3952         enddo
3953 c       write (2,*) "i",i
3954 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
3955 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
3956 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
3957 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
3958 c      & " xy",scalar(x_prime(1),y_prime(1)),
3959 c      & " xz",scalar(x_prime(1),z_prime(1)),
3960 c      & " yy",scalar(y_prime(1),y_prime(1)),
3961 c      & " yz",scalar(y_prime(1),z_prime(1)),
3962 c      & " zz",scalar(z_prime(1),z_prime(1))
3963 c
3964 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
3965 C to local coordinate system. Store in xx, yy, zz.
3966 c
3967         xx=0.0d0
3968         yy=0.0d0
3969         zz=0.0d0
3970         do j = 1,3
3971           xx = xx + x_prime(j)*dc_norm(j,i+nres)
3972           yy = yy + y_prime(j)*dc_norm(j,i+nres)
3973           zz = zz + z_prime(j)*dc_norm(j,i+nres)
3974         enddo
3975
3976         xxtab(i)=xx
3977         yytab(i)=yy
3978         zztab(i)=zz
3979 C
3980 C Compute the energy of the ith side cbain
3981 C
3982 c        write (2,*) "xx",xx," yy",yy," zz",zz
3983         it=itype(i)
3984         do j = 1,65
3985           x(j) = sc_parmin(j,it)
3986         enddo
3987 #ifdef CHECK_COORD
3988 Cc diagnostics - remove later
3989         xx1 = dcos(alph(2))
3990         yy1 = dsin(alph(2))*dcos(omeg(2))
3991         zz1 = -dsin(alph(2))*dsin(omeg(2))
3992         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
3993      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
3994      &    xx1,yy1,zz1
3995 C,"  --- ", xx_w,yy_w,zz_w
3996 c end diagnostics
3997 #endif
3998         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
3999      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4000      &   + x(10)*yy*zz
4001         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4002      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4003      & + x(20)*yy*zz
4004         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4005      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4006      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4007      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4008      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4009      &  +x(40)*xx*yy*zz
4010         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4011      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4012      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4013      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4014      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4015      &  +x(60)*xx*yy*zz
4016         dsc_i   = 0.743d0+x(61)
4017         dp2_i   = 1.9d0+x(62)
4018         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4019      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4020         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4021      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4022         s1=(1+x(63))/(0.1d0 + dscp1)
4023         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4024         s2=(1+x(65))/(0.1d0 + dscp2)
4025         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4026         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4027      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4028 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4029 c     &   sumene4,
4030 c     &   dscp1,dscp2,sumene
4031 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4032         escloc = escloc + sumene
4033 c        write (2,*) "escloc",escloc
4034         if (.not. calc_grad) goto 1
4035
4036 #ifdef DEBUG2
4037 C
4038 C This section to check the numerical derivatives of the energy of ith side
4039 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4040 C #define DEBUG in the code to turn it on.
4041 C
4042         write (2,*) "sumene               =",sumene
4043         aincr=1.0d-7
4044         xxsave=xx
4045         xx=xx+aincr
4046         write (2,*) xx,yy,zz
4047         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4048         de_dxx_num=(sumenep-sumene)/aincr
4049         xx=xxsave
4050         write (2,*) "xx+ sumene from enesc=",sumenep
4051         yysave=yy
4052         yy=yy+aincr
4053         write (2,*) xx,yy,zz
4054         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4055         de_dyy_num=(sumenep-sumene)/aincr
4056         yy=yysave
4057         write (2,*) "yy+ sumene from enesc=",sumenep
4058         zzsave=zz
4059         zz=zz+aincr
4060         write (2,*) xx,yy,zz
4061         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4062         de_dzz_num=(sumenep-sumene)/aincr
4063         zz=zzsave
4064         write (2,*) "zz+ sumene from enesc=",sumenep
4065         costsave=cost2tab(i+1)
4066         sintsave=sint2tab(i+1)
4067         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4068         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4069         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4070         de_dt_num=(sumenep-sumene)/aincr
4071         write (2,*) " t+ sumene from enesc=",sumenep
4072         cost2tab(i+1)=costsave
4073         sint2tab(i+1)=sintsave
4074 C End of diagnostics section.
4075 #endif
4076 C
4077 C Compute the gradient of esc
4078 C
4079         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4080         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4081         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4082         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4083         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4084         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4085         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4086         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4087         pom1=(sumene3*sint2tab(i+1)+sumene1)
4088      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4089         pom2=(sumene4*cost2tab(i+1)+sumene2)
4090      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4091         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4092         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4093      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4094      &  +x(40)*yy*zz
4095         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4096         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4097      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4098      &  +x(60)*yy*zz
4099         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4100      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4101      &        +(pom1+pom2)*pom_dx
4102 #ifdef DEBUG
4103         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4104 #endif
4105 C
4106         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4107         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4108      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4109      &  +x(40)*xx*zz
4110         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4111         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4112      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4113      &  +x(59)*zz**2 +x(60)*xx*zz
4114         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4115      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4116      &        +(pom1-pom2)*pom_dy
4117 #ifdef DEBUG
4118         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4119 #endif
4120 C
4121         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4122      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4123      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4124      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4125      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4126      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4127      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4128      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4129 #ifdef DEBUG
4130         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4131 #endif
4132 C
4133         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4134      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4135      &  +pom1*pom_dt1+pom2*pom_dt2
4136 #ifdef DEBUG
4137         write(2,*), "de_dt = ", de_dt,de_dt_num
4138 #endif
4139 c
4140 C
4141        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4142        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4143        cosfac2xx=cosfac2*xx
4144        sinfac2yy=sinfac2*yy
4145        do k = 1,3
4146          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4147      &      vbld_inv(i+1)
4148          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4149      &      vbld_inv(i)
4150          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4151          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4152 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4153 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4154 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4155 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4156          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4157          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4158          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4159          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4160          dZZ_Ci1(k)=0.0d0
4161          dZZ_Ci(k)=0.0d0
4162          do j=1,3
4163            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4164            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4165          enddo
4166
4167          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4168          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4169          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4170 c
4171          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4172          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4173        enddo
4174
4175        do k=1,3
4176          dXX_Ctab(k,i)=dXX_Ci(k)
4177          dXX_C1tab(k,i)=dXX_Ci1(k)
4178          dYY_Ctab(k,i)=dYY_Ci(k)
4179          dYY_C1tab(k,i)=dYY_Ci1(k)
4180          dZZ_Ctab(k,i)=dZZ_Ci(k)
4181          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4182          dXX_XYZtab(k,i)=dXX_XYZ(k)
4183          dYY_XYZtab(k,i)=dYY_XYZ(k)
4184          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4185        enddo
4186
4187        do k = 1,3
4188 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4189 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4190 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4191 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4192 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4193 c     &    dt_dci(k)
4194 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4195 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4196          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4197      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4198          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4199      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4200          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4201      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4202        enddo
4203 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4204 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4205
4206 C to check gradient call subroutine check_grad
4207
4208     1 continue
4209       enddo
4210       return
4211       end
4212 #endif
4213 c------------------------------------------------------------------------------
4214       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4215 C
4216 C This procedure calculates two-body contact function g(rij) and its derivative:
4217 C
4218 C           eps0ij                                     !       x < -1
4219 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4220 C            0                                         !       x > 1
4221 C
4222 C where x=(rij-r0ij)/delta
4223 C
4224 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4225 C
4226       implicit none
4227       double precision rij,r0ij,eps0ij,fcont,fprimcont
4228       double precision x,x2,x4,delta
4229 c     delta=0.02D0*r0ij
4230 c      delta=0.2D0*r0ij
4231       x=(rij-r0ij)/delta
4232       if (x.lt.-1.0D0) then
4233         fcont=eps0ij
4234         fprimcont=0.0D0
4235       else if (x.le.1.0D0) then
4236         x2=x*x
4237         x4=x2*x2
4238         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4239         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4240       else
4241         fcont=0.0D0
4242         fprimcont=0.0D0
4243       endif
4244       return
4245       end
4246 c------------------------------------------------------------------------------
4247       subroutine splinthet(theti,delta,ss,ssder)
4248       implicit real*8 (a-h,o-z)
4249       include 'DIMENSIONS'
4250       include 'DIMENSIONS.ZSCOPT'
4251       include 'COMMON.VAR'
4252       include 'COMMON.GEO'
4253       thetup=pi-delta
4254       thetlow=delta
4255       if (theti.gt.pipol) then
4256         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4257       else
4258         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4259         ssder=-ssder
4260       endif
4261       return
4262       end
4263 c------------------------------------------------------------------------------
4264       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4265       implicit none
4266       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4267       double precision ksi,ksi2,ksi3,a1,a2,a3
4268       a1=fprim0*delta/(f1-f0)
4269       a2=3.0d0-2.0d0*a1
4270       a3=a1-2.0d0
4271       ksi=(x-x0)/delta
4272       ksi2=ksi*ksi
4273       ksi3=ksi2*ksi
4274       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4275       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4276       return
4277       end
4278 c------------------------------------------------------------------------------
4279       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4280       implicit none
4281       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4282       double precision ksi,ksi2,ksi3,a1,a2,a3
4283       ksi=(x-x0)/delta
4284       ksi2=ksi*ksi
4285       ksi3=ksi2*ksi
4286       a1=fprim0x*delta
4287       a2=3*(f1x-f0x)-2*fprim0x*delta
4288       a3=fprim0x*delta-2*(f1x-f0x)
4289       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4290       return
4291       end
4292 C-----------------------------------------------------------------------------
4293 #ifdef CRYST_TOR
4294 C-----------------------------------------------------------------------------
4295       subroutine etor(etors,edihcnstr,fact)
4296       implicit real*8 (a-h,o-z)
4297       include 'DIMENSIONS'
4298       include 'DIMENSIONS.ZSCOPT'
4299       include 'COMMON.VAR'
4300       include 'COMMON.GEO'
4301       include 'COMMON.LOCAL'
4302       include 'COMMON.TORSION'
4303       include 'COMMON.INTERACT'
4304       include 'COMMON.DERIV'
4305       include 'COMMON.CHAIN'
4306       include 'COMMON.NAMES'
4307       include 'COMMON.IOUNITS'
4308       include 'COMMON.FFIELD'
4309       include 'COMMON.TORCNSTR'
4310       logical lprn
4311 C Set lprn=.true. for debugging
4312       lprn=.false.
4313 c      lprn=.true.
4314       etors=0.0D0
4315       do i=iphi_start,iphi_end
4316         itori=itortyp(itype(i-2))
4317         itori1=itortyp(itype(i-1))
4318         phii=phi(i)
4319         gloci=0.0D0
4320 C Proline-Proline pair is a special case...
4321         if (itori.eq.3 .and. itori1.eq.3) then
4322           if (phii.gt.-dwapi3) then
4323             cosphi=dcos(3*phii)
4324             fac=1.0D0/(1.0D0-cosphi)
4325             etorsi=v1(1,3,3)*fac
4326             etorsi=etorsi+etorsi
4327             etors=etors+etorsi-v1(1,3,3)
4328             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4329           endif
4330           do j=1,3
4331             v1ij=v1(j+1,itori,itori1)
4332             v2ij=v2(j+1,itori,itori1)
4333             cosphi=dcos(j*phii)
4334             sinphi=dsin(j*phii)
4335             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4336             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4337           enddo
4338         else
4339           do j=1,nterm_old
4340             v1ij=v1(j,itori,itori1)
4341             v2ij=v2(j,itori,itori1)
4342             cosphi=dcos(j*phii)
4343             sinphi=dsin(j*phii)
4344             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4345             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4346           enddo
4347         endif
4348         if (lprn)
4349      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4350      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4351      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4352         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4353 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4354       enddo
4355 ! 6/20/98 - dihedral angle constraints
4356       edihcnstr=0.0d0
4357       do i=1,ndih_constr
4358         itori=idih_constr(i)
4359         phii=phi(itori)
4360         difi=phii-phi0(i)
4361         if (difi.gt.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         else if (difi.lt.-drange(i)) then
4366           difi=difi+drange(i)
4367           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4368           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4369         endif
4370 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4371 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4372       enddo
4373 !      write (iout,*) 'edihcnstr',edihcnstr
4374       return
4375       end
4376 c------------------------------------------------------------------------------
4377 #else
4378       subroutine etor(etors,edihcnstr,fact)
4379       implicit real*8 (a-h,o-z)
4380       include 'DIMENSIONS'
4381       include 'DIMENSIONS.ZSCOPT'
4382       include 'COMMON.VAR'
4383       include 'COMMON.GEO'
4384       include 'COMMON.LOCAL'
4385       include 'COMMON.TORSION'
4386       include 'COMMON.INTERACT'
4387       include 'COMMON.DERIV'
4388       include 'COMMON.CHAIN'
4389       include 'COMMON.NAMES'
4390       include 'COMMON.IOUNITS'
4391       include 'COMMON.FFIELD'
4392       include 'COMMON.TORCNSTR'
4393       logical lprn
4394 C Set lprn=.true. for debugging
4395       lprn=.false.
4396 c      lprn=.true.
4397       etors=0.0D0
4398       do i=iphi_start,iphi_end
4399         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4400         itori=itortyp(itype(i-2))
4401         itori1=itortyp(itype(i-1))
4402         phii=phi(i)
4403         gloci=0.0D0
4404 C Regular cosine and sine terms
4405         do j=1,nterm(itori,itori1)
4406           v1ij=v1(j,itori,itori1)
4407           v2ij=v2(j,itori,itori1)
4408           cosphi=dcos(j*phii)
4409           sinphi=dsin(j*phii)
4410           etors=etors+v1ij*cosphi+v2ij*sinphi
4411           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4412         enddo
4413 C Lorentz terms
4414 C                         v1
4415 C  E = SUM ----------------------------------- - v1
4416 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4417 C
4418         cosphi=dcos(0.5d0*phii)
4419         sinphi=dsin(0.5d0*phii)
4420         do j=1,nlor(itori,itori1)
4421           vl1ij=vlor1(j,itori,itori1)
4422           vl2ij=vlor2(j,itori,itori1)
4423           vl3ij=vlor3(j,itori,itori1)
4424           pom=vl2ij*cosphi+vl3ij*sinphi
4425           pom1=1.0d0/(pom*pom+1.0d0)
4426           etors=etors+vl1ij*pom1
4427           pom=-pom*pom1*pom1
4428           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4429         enddo
4430 C Subtract the constant term
4431         etors=etors-v0(itori,itori1)
4432         if (lprn)
4433      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4434      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4435      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4436         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4437 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4438  1215   continue
4439       enddo
4440 ! 6/20/98 - dihedral angle constraints
4441       edihcnstr=0.0d0
4442       do i=1,ndih_constr
4443         itori=idih_constr(i)
4444         phii=phi(itori)
4445         difi=pinorm(phii-phi0(i))
4446         edihi=0.0d0
4447         if (difi.gt.drange(i)) then
4448           difi=difi-drange(i)
4449           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4450           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4451           edihi=0.25d0*ftors*difi**4
4452         else if (difi.lt.-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
4458           difi=0.0d0
4459         endif
4460 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
4461 c     &    drange(i),edihi
4462 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4463 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4464       enddo
4465 !      write (iout,*) 'edihcnstr',edihcnstr
4466       return
4467       end
4468 c----------------------------------------------------------------------------
4469       subroutine etor_d(etors_d,fact2)
4470 C 6/23/01 Compute double torsional energy
4471       implicit real*8 (a-h,o-z)
4472       include 'DIMENSIONS'
4473       include 'DIMENSIONS.ZSCOPT'
4474       include 'COMMON.VAR'
4475       include 'COMMON.GEO'
4476       include 'COMMON.LOCAL'
4477       include 'COMMON.TORSION'
4478       include 'COMMON.INTERACT'
4479       include 'COMMON.DERIV'
4480       include 'COMMON.CHAIN'
4481       include 'COMMON.NAMES'
4482       include 'COMMON.IOUNITS'
4483       include 'COMMON.FFIELD'
4484       include 'COMMON.TORCNSTR'
4485       logical lprn
4486 C Set lprn=.true. for debugging
4487       lprn=.false.
4488 c     lprn=.true.
4489       etors_d=0.0D0
4490       do i=iphi_start,iphi_end-1
4491         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
4492      &     goto 1215
4493         itori=itortyp(itype(i-2))
4494         itori1=itortyp(itype(i-1))
4495         itori2=itortyp(itype(i))
4496         phii=phi(i)
4497         phii1=phi(i+1)
4498         gloci1=0.0D0
4499         gloci2=0.0D0
4500 C Regular cosine and sine terms
4501         do j=1,ntermd_1(itori,itori1,itori2)
4502           v1cij=v1c(1,j,itori,itori1,itori2)
4503           v1sij=v1s(1,j,itori,itori1,itori2)
4504           v2cij=v1c(2,j,itori,itori1,itori2)
4505           v2sij=v1s(2,j,itori,itori1,itori2)
4506           cosphi1=dcos(j*phii)
4507           sinphi1=dsin(j*phii)
4508           cosphi2=dcos(j*phii1)
4509           sinphi2=dsin(j*phii1)
4510           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
4511      &     v2cij*cosphi2+v2sij*sinphi2
4512           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
4513           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
4514         enddo
4515         do k=2,ntermd_2(itori,itori1,itori2)
4516           do l=1,k-1
4517             v1cdij = v2c(k,l,itori,itori1,itori2)
4518             v2cdij = v2c(l,k,itori,itori1,itori2)
4519             v1sdij = v2s(k,l,itori,itori1,itori2)
4520             v2sdij = v2s(l,k,itori,itori1,itori2)
4521             cosphi1p2=dcos(l*phii+(k-l)*phii1)
4522             cosphi1m2=dcos(l*phii-(k-l)*phii1)
4523             sinphi1p2=dsin(l*phii+(k-l)*phii1)
4524             sinphi1m2=dsin(l*phii-(k-l)*phii1)
4525             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
4526      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
4527             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
4528      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
4529             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
4530      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
4531           enddo
4532         enddo
4533         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
4534         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
4535  1215   continue
4536       enddo
4537       return
4538       end
4539 #endif
4540 c------------------------------------------------------------------------------
4541       subroutine eback_sc_corr(esccor)
4542 c 7/21/2007 Correlations between the backbone-local and side-chain-local
4543 c        conformational states; temporarily implemented as differences
4544 c        between UNRES torsional potentials (dependent on three types of
4545 c        residues) and the torsional potentials dependent on all 20 types
4546 c        of residues computed from AM1 energy surfaces of terminally-blocked
4547 c        amino-acid residues.
4548       implicit real*8 (a-h,o-z)
4549       include 'DIMENSIONS'
4550       include 'DIMENSIONS.ZSCOPT'
4551       include 'COMMON.VAR'
4552       include 'COMMON.GEO'
4553       include 'COMMON.LOCAL'
4554       include 'COMMON.TORSION'
4555       include 'COMMON.SCCOR'
4556       include 'COMMON.INTERACT'
4557       include 'COMMON.DERIV'
4558       include 'COMMON.CHAIN'
4559       include 'COMMON.NAMES'
4560       include 'COMMON.IOUNITS'
4561       include 'COMMON.FFIELD'
4562       include 'COMMON.CONTROL'
4563       logical lprn
4564 C Set lprn=.true. for debugging
4565       lprn=.false.
4566 c      lprn=.true.
4567 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
4568       esccor=0.0D0
4569       do i=itau_start,itau_end
4570         esccor_ii=0.0D0
4571         isccori=isccortyp(itype(i-2))
4572         isccori1=isccortyp(itype(i-1))
4573         phii=phi(i)
4574 cccc  Added 9 May 2012
4575 cc Tauangle is torsional engle depending on the value of first digit
4576 c(see comment below)
4577 cc Omicron is flat angle depending on the value of first digit
4578 c(see comment below)
4579
4580
4581         do intertyp=1,3 !intertyp
4582 cc Added 09 May 2012 (Adasko)
4583 cc  Intertyp means interaction type of backbone mainchain correlation:
4584 c   1 = SC...Ca...Ca...Ca
4585 c   2 = Ca...Ca...Ca...SC
4586 c   3 = SC...Ca...Ca...SCi
4587         gloci=0.0D0
4588         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
4589      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
4590      &      (itype(i-1).eq.21)))
4591      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
4592      &     .or.(itype(i-2).eq.21)))
4593      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
4594      &      (itype(i-1).eq.21)))) cycle
4595         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
4596         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
4597      & cycle
4598         do j=1,nterm_sccor(isccori,isccori1)
4599           v1ij=v1sccor(j,intertyp,isccori,isccori1)
4600           v2ij=v2sccor(j,intertyp,isccori,isccori1)
4601           cosphi=dcos(j*tauangle(intertyp,i))
4602           sinphi=dsin(j*tauangle(intertyp,i))
4603           esccor=esccor+v1ij*cosphi+v2ij*sinphi
4604 <<<<<<< HEAD
4605 =======
4606 #ifdef DEBUG
4607           esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
4608 #endif
4609 >>>>>>> 3d6f9e7... Adam's changes to wham and cluster following previous commit
4610           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4611         enddo
4612         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
4613 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
4614 c     &gloc_sc(intertyp,i-3,icg)
4615         if (lprn)
4616      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4617      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4618      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
4619      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
4620         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
4621        enddo !intertyp
4622       enddo
4623 c        do i=1,nres
4624 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
4625 c        enddo
4626       return
4627       end
4628 c------------------------------------------------------------------------------
4629       subroutine multibody(ecorr)
4630 C This subroutine calculates multi-body contributions to energy following
4631 C the idea of Skolnick et al. If side chains I and J make a contact and
4632 C at the same time side chains I+1 and J+1 make a contact, an extra
4633 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
4634       implicit real*8 (a-h,o-z)
4635       include 'DIMENSIONS'
4636       include 'COMMON.IOUNITS'
4637       include 'COMMON.DERIV'
4638       include 'COMMON.INTERACT'
4639       include 'COMMON.CONTACTS'
4640       double precision gx(3),gx1(3)
4641       logical lprn
4642
4643 C Set lprn=.true. for debugging
4644       lprn=.false.
4645
4646       if (lprn) then
4647         write (iout,'(a)') 'Contact function values:'
4648         do i=nnt,nct-2
4649           write (iout,'(i2,20(1x,i2,f10.5))')
4650      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
4651         enddo
4652       endif
4653       ecorr=0.0D0
4654       do i=nnt,nct
4655         do j=1,3
4656           gradcorr(j,i)=0.0D0
4657           gradxorr(j,i)=0.0D0
4658         enddo
4659       enddo
4660       do i=nnt,nct-2
4661
4662         DO ISHIFT = 3,4
4663
4664         i1=i+ishift
4665         num_conti=num_cont(i)
4666         num_conti1=num_cont(i1)
4667         do jj=1,num_conti
4668           j=jcont(jj,i)
4669           do kk=1,num_conti1
4670             j1=jcont(kk,i1)
4671             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
4672 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4673 cd   &                   ' ishift=',ishift
4674 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
4675 C The system gains extra energy.
4676               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
4677             endif   ! j1==j+-ishift
4678           enddo     ! kk
4679         enddo       ! jj
4680
4681         ENDDO ! ISHIFT
4682
4683       enddo         ! i
4684       return
4685       end
4686 c------------------------------------------------------------------------------
4687       double precision function esccorr(i,j,k,l,jj,kk)
4688       implicit real*8 (a-h,o-z)
4689       include 'DIMENSIONS'
4690       include 'COMMON.IOUNITS'
4691       include 'COMMON.DERIV'
4692       include 'COMMON.INTERACT'
4693       include 'COMMON.CONTACTS'
4694       double precision gx(3),gx1(3)
4695       logical lprn
4696       lprn=.false.
4697       eij=facont(jj,i)
4698       ekl=facont(kk,k)
4699 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
4700 C Calculate the multi-body contribution to energy.
4701 C Calculate multi-body contributions to the gradient.
4702 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
4703 cd   & k,l,(gacont(m,kk,k),m=1,3)
4704       do m=1,3
4705         gx(m) =ekl*gacont(m,jj,i)
4706         gx1(m)=eij*gacont(m,kk,k)
4707         gradxorr(m,i)=gradxorr(m,i)-gx(m)
4708         gradxorr(m,j)=gradxorr(m,j)+gx(m)
4709         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
4710         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
4711       enddo
4712       do m=i,j-1
4713         do ll=1,3
4714           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
4715         enddo
4716       enddo
4717       do m=k,l-1
4718         do ll=1,3
4719           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
4720         enddo
4721       enddo
4722       esccorr=-eij*ekl
4723       return
4724       end
4725 c------------------------------------------------------------------------------
4726 #ifdef MPL
4727       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
4728       implicit real*8 (a-h,o-z)
4729       include 'DIMENSIONS'
4730       integer dimen1,dimen2,atom,indx
4731       double precision buffer(dimen1,dimen2)
4732       double precision zapas
4733       common /contacts_hb/ zapas(3,20,maxres,7),
4734      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4735      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4736       num_kont=num_cont_hb(atom)
4737       do i=1,num_kont
4738         do k=1,7
4739           do j=1,3
4740             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
4741           enddo ! j
4742         enddo ! k
4743         buffer(i,indx+22)=facont_hb(i,atom)
4744         buffer(i,indx+23)=ees0p(i,atom)
4745         buffer(i,indx+24)=ees0m(i,atom)
4746         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
4747       enddo ! i
4748       buffer(1,indx+26)=dfloat(num_kont)
4749       return
4750       end
4751 c------------------------------------------------------------------------------
4752       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
4753       implicit real*8 (a-h,o-z)
4754       include 'DIMENSIONS'
4755       integer dimen1,dimen2,atom,indx
4756       double precision buffer(dimen1,dimen2)
4757       double precision zapas
4758       common /contacts_hb/ zapas(3,20,maxres,7),
4759      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4760      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4761       num_kont=buffer(1,indx+26)
4762       num_kont_old=num_cont_hb(atom)
4763       num_cont_hb(atom)=num_kont+num_kont_old
4764       do i=1,num_kont
4765         ii=i+num_kont_old
4766         do k=1,7
4767           do j=1,3
4768             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
4769           enddo ! j
4770         enddo ! k
4771         facont_hb(ii,atom)=buffer(i,indx+22)
4772         ees0p(ii,atom)=buffer(i,indx+23)
4773         ees0m(ii,atom)=buffer(i,indx+24)
4774         jcont_hb(ii,atom)=buffer(i,indx+25)
4775       enddo ! i
4776       return
4777       end
4778 c------------------------------------------------------------------------------
4779 #endif
4780       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
4781 C This subroutine calculates multi-body contributions to hydrogen-bonding
4782       implicit real*8 (a-h,o-z)
4783       include 'DIMENSIONS'
4784       include 'DIMENSIONS.ZSCOPT'
4785       include 'COMMON.IOUNITS'
4786 #ifdef MPL
4787       include 'COMMON.INFO'
4788 #endif
4789       include 'COMMON.FFIELD'
4790       include 'COMMON.DERIV'
4791       include 'COMMON.INTERACT'
4792       include 'COMMON.CONTACTS'
4793 #ifdef MPL
4794       parameter (max_cont=maxconts)
4795       parameter (max_dim=2*(8*3+2))
4796       parameter (msglen1=max_cont*max_dim*4)
4797       parameter (msglen2=2*msglen1)
4798       integer source,CorrelType,CorrelID,Error
4799       double precision buffer(max_cont,max_dim)
4800 #endif
4801       double precision gx(3),gx1(3)
4802       logical lprn,ldone
4803
4804 C Set lprn=.true. for debugging
4805       lprn=.false.
4806 #ifdef MPL
4807       n_corr=0
4808       n_corr1=0
4809       if (fgProcs.le.1) goto 30
4810       if (lprn) then
4811         write (iout,'(a)') 'Contact function values:'
4812         do i=nnt,nct-2
4813           write (iout,'(2i3,50(1x,i2,f5.2))')
4814      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4815      &    j=1,num_cont_hb(i))
4816         enddo
4817       endif
4818 C Caution! Following code assumes that electrostatic interactions concerning
4819 C a given atom are split among at most two processors!
4820       CorrelType=477
4821       CorrelID=MyID+1
4822       ldone=.false.
4823       do i=1,max_cont
4824         do j=1,max_dim
4825           buffer(i,j)=0.0D0
4826         enddo
4827       enddo
4828       mm=mod(MyRank,2)
4829 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
4830       if (mm) 20,20,10
4831    10 continue
4832 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
4833       if (MyRank.gt.0) then
4834 C Send correlation contributions to the preceding processor
4835         msglen=msglen1
4836         nn=num_cont_hb(iatel_s)
4837         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
4838 cd      write (iout,*) 'The BUFFER array:'
4839 cd      do i=1,nn
4840 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
4841 cd      enddo
4842         if (ielstart(iatel_s).gt.iatel_s+ispp) then
4843           msglen=msglen2
4844             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
4845 C Clear the contacts of the atom passed to the neighboring processor
4846         nn=num_cont_hb(iatel_s+1)
4847 cd      do i=1,nn
4848 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
4849 cd      enddo
4850             num_cont_hb(iatel_s)=0
4851         endif
4852 cd      write (iout,*) 'Processor ',MyID,MyRank,
4853 cd   & ' is sending correlation contribution to processor',MyID-1,
4854 cd   & ' msglen=',msglen
4855 cd      write (*,*) 'Processor ',MyID,MyRank,
4856 cd   & ' is sending correlation contribution to processor',MyID-1,
4857 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4858         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
4859 cd      write (iout,*) 'Processor ',MyID,
4860 cd   & ' has sent correlation contribution to processor',MyID-1,
4861 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4862 cd      write (*,*) 'Processor ',MyID,
4863 cd   & ' has sent correlation contribution to processor',MyID-1,
4864 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4865         msglen=msglen1
4866       endif ! (MyRank.gt.0)
4867       if (ldone) goto 30
4868       ldone=.true.
4869    20 continue
4870 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
4871       if (MyRank.lt.fgProcs-1) then
4872 C Receive correlation contributions from the next processor
4873         msglen=msglen1
4874         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
4875 cd      write (iout,*) 'Processor',MyID,
4876 cd   & ' is receiving correlation contribution from processor',MyID+1,
4877 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4878 cd      write (*,*) 'Processor',MyID,
4879 cd   & ' is receiving correlation contribution from processor',MyID+1,
4880 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4881         nbytes=-1
4882         do while (nbytes.le.0)
4883           call mp_probe(MyID+1,CorrelType,nbytes)
4884         enddo
4885 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
4886         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
4887 cd      write (iout,*) 'Processor',MyID,
4888 cd   & ' has received correlation contribution from processor',MyID+1,
4889 cd   & ' msglen=',msglen,' nbytes=',nbytes
4890 cd      write (iout,*) 'The received BUFFER array:'
4891 cd      do i=1,max_cont
4892 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
4893 cd      enddo
4894         if (msglen.eq.msglen1) then
4895           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
4896         else if (msglen.eq.msglen2)  then
4897           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
4898           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
4899         else
4900           write (iout,*)
4901      & 'ERROR!!!! message length changed while processing correlations.'
4902           write (*,*)
4903      & 'ERROR!!!! message length changed while processing correlations.'
4904           call mp_stopall(Error)
4905         endif ! msglen.eq.msglen1
4906       endif ! MyRank.lt.fgProcs-1
4907       if (ldone) goto 30
4908       ldone=.true.
4909       goto 10
4910    30 continue
4911 #endif
4912       if (lprn) then
4913         write (iout,'(a)') 'Contact function values:'
4914         do i=nnt,nct-2
4915           write (iout,'(2i3,50(1x,i2,f5.2))')
4916      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4917      &    j=1,num_cont_hb(i))
4918         enddo
4919       endif
4920       ecorr=0.0D0
4921 C Remove the loop below after debugging !!!
4922       do i=nnt,nct
4923         do j=1,3
4924           gradcorr(j,i)=0.0D0
4925           gradxorr(j,i)=0.0D0
4926         enddo
4927       enddo
4928 C Calculate the local-electrostatic correlation terms
4929       do i=iatel_s,iatel_e+1
4930         i1=i+1
4931         num_conti=num_cont_hb(i)
4932         num_conti1=num_cont_hb(i+1)
4933         do jj=1,num_conti
4934           j=jcont_hb(jj,i)
4935           do kk=1,num_conti1
4936             j1=jcont_hb(kk,i1)
4937 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4938 c     &         ' jj=',jj,' kk=',kk
4939             if (j1.eq.j+1 .or. j1.eq.j-1) then
4940 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
4941 C The system gains extra energy.
4942               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
4943               n_corr=n_corr+1
4944             else if (j1.eq.j) then
4945 C Contacts I-J and I-(J+1) occur simultaneously.
4946 C The system loses extra energy.
4947 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
4948             endif
4949           enddo ! kk
4950           do kk=1,num_conti
4951             j1=jcont_hb(kk,i)
4952 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4953 c    &         ' jj=',jj,' kk=',kk
4954             if (j1.eq.j+1) then
4955 C Contacts I-J and (I+1)-J occur simultaneously.
4956 C The system loses extra energy.
4957 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
4958             endif ! j1==j+1
4959           enddo ! kk
4960         enddo ! jj
4961       enddo ! i
4962       return
4963       end
4964 c------------------------------------------------------------------------------
4965       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
4966      &  n_corr1)
4967 C This subroutine calculates multi-body contributions to hydrogen-bonding
4968       implicit real*8 (a-h,o-z)
4969       include 'DIMENSIONS'
4970       include 'DIMENSIONS.ZSCOPT'
4971       include 'COMMON.IOUNITS'
4972 #ifdef MPL
4973       include 'COMMON.INFO'
4974 #endif
4975       include 'COMMON.FFIELD'
4976       include 'COMMON.DERIV'
4977       include 'COMMON.INTERACT'
4978       include 'COMMON.CONTACTS'
4979 #ifdef MPL
4980       parameter (max_cont=maxconts)
4981       parameter (max_dim=2*(8*3+2))
4982       parameter (msglen1=max_cont*max_dim*4)
4983       parameter (msglen2=2*msglen1)
4984       integer source,CorrelType,CorrelID,Error
4985       double precision buffer(max_cont,max_dim)
4986 #endif
4987       double precision gx(3),gx1(3)
4988       logical lprn,ldone
4989
4990 C Set lprn=.true. for debugging
4991       lprn=.false.
4992       eturn6=0.0d0
4993 #ifdef MPL
4994       n_corr=0
4995       n_corr1=0
4996       if (fgProcs.le.1) goto 30
4997       if (lprn) then
4998         write (iout,'(a)') 'Contact function values:'
4999         do i=nnt,nct-2
5000           write (iout,'(2i3,50(1x,i2,f5.2))')
5001      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5002      &    j=1,num_cont_hb(i))
5003         enddo
5004       endif
5005 C Caution! Following code assumes that electrostatic interactions concerning
5006 C a given atom are split among at most two processors!
5007       CorrelType=477
5008       CorrelID=MyID+1
5009       ldone=.false.
5010       do i=1,max_cont
5011         do j=1,max_dim
5012           buffer(i,j)=0.0D0
5013         enddo
5014       enddo
5015       mm=mod(MyRank,2)
5016 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5017       if (mm) 20,20,10
5018    10 continue
5019 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5020       if (MyRank.gt.0) then
5021 C Send correlation contributions to the preceding processor
5022         msglen=msglen1
5023         nn=num_cont_hb(iatel_s)
5024         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5025 cd      write (iout,*) 'The BUFFER array:'
5026 cd      do i=1,nn
5027 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5028 cd      enddo
5029         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5030           msglen=msglen2
5031             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5032 C Clear the contacts of the atom passed to the neighboring processor
5033         nn=num_cont_hb(iatel_s+1)
5034 cd      do i=1,nn
5035 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5036 cd      enddo
5037             num_cont_hb(iatel_s)=0
5038         endif
5039 cd      write (iout,*) 'Processor ',MyID,MyRank,
5040 cd   & ' is sending correlation contribution to processor',MyID-1,
5041 cd   & ' msglen=',msglen
5042 cd      write (*,*) 'Processor ',MyID,MyRank,
5043 cd   & ' is sending correlation contribution to processor',MyID-1,
5044 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5045         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5046 cd      write (iout,*) 'Processor ',MyID,
5047 cd   & ' has sent correlation contribution to processor',MyID-1,
5048 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5049 cd      write (*,*) 'Processor ',MyID,
5050 cd   & ' has sent correlation contribution to processor',MyID-1,
5051 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5052         msglen=msglen1
5053       endif ! (MyRank.gt.0)
5054       if (ldone) goto 30
5055       ldone=.true.
5056    20 continue
5057 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5058       if (MyRank.lt.fgProcs-1) then
5059 C Receive correlation contributions from the next processor
5060         msglen=msglen1
5061         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5062 cd      write (iout,*) 'Processor',MyID,
5063 cd   & ' is receiving correlation contribution from processor',MyID+1,
5064 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5065 cd      write (*,*) 'Processor',MyID,
5066 cd   & ' is receiving correlation contribution from processor',MyID+1,
5067 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5068         nbytes=-1
5069         do while (nbytes.le.0)
5070           call mp_probe(MyID+1,CorrelType,nbytes)
5071         enddo
5072 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5073         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5074 cd      write (iout,*) 'Processor',MyID,
5075 cd   & ' has received correlation contribution from processor',MyID+1,
5076 cd   & ' msglen=',msglen,' nbytes=',nbytes
5077 cd      write (iout,*) 'The received BUFFER array:'
5078 cd      do i=1,max_cont
5079 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5080 cd      enddo
5081         if (msglen.eq.msglen1) then
5082           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5083         else if (msglen.eq.msglen2)  then
5084           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5085           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5086         else
5087           write (iout,*)
5088      & 'ERROR!!!! message length changed while processing correlations.'
5089           write (*,*)
5090      & 'ERROR!!!! message length changed while processing correlations.'
5091           call mp_stopall(Error)
5092         endif ! msglen.eq.msglen1
5093       endif ! MyRank.lt.fgProcs-1
5094       if (ldone) goto 30
5095       ldone=.true.
5096       goto 10
5097    30 continue
5098 #endif
5099       if (lprn) then
5100         write (iout,'(a)') 'Contact function values:'
5101         do i=nnt,nct-2
5102           write (iout,'(2i3,50(1x,i2,f5.2))')
5103      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5104      &    j=1,num_cont_hb(i))
5105         enddo
5106       endif
5107       ecorr=0.0D0
5108       ecorr5=0.0d0
5109       ecorr6=0.0d0
5110 C Remove the loop below after debugging !!!
5111       do i=nnt,nct
5112         do j=1,3
5113           gradcorr(j,i)=0.0D0
5114           gradxorr(j,i)=0.0D0
5115         enddo
5116       enddo
5117 C Calculate the dipole-dipole interaction energies
5118       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5119       do i=iatel_s,iatel_e+1
5120         num_conti=num_cont_hb(i)
5121         do jj=1,num_conti
5122           j=jcont_hb(jj,i)
5123           call dipole(i,j,jj)
5124         enddo
5125       enddo
5126       endif
5127 C Calculate the local-electrostatic correlation terms
5128       do i=iatel_s,iatel_e+1
5129         i1=i+1
5130         num_conti=num_cont_hb(i)
5131         num_conti1=num_cont_hb(i+1)
5132         do jj=1,num_conti
5133           j=jcont_hb(jj,i)
5134           do kk=1,num_conti1
5135             j1=jcont_hb(kk,i1)
5136 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5137 c     &         ' jj=',jj,' kk=',kk
5138             if (j1.eq.j+1 .or. j1.eq.j-1) then
5139 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5140 C The system gains extra energy.
5141               n_corr=n_corr+1
5142               sqd1=dsqrt(d_cont(jj,i))
5143               sqd2=dsqrt(d_cont(kk,i1))
5144               sred_geom = sqd1*sqd2
5145               IF (sred_geom.lt.cutoff_corr) THEN
5146                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5147      &            ekont,fprimcont)
5148 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5149 c     &         ' jj=',jj,' kk=',kk
5150                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5151                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5152                 do l=1,3
5153                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5154                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5155                 enddo
5156                 n_corr1=n_corr1+1
5157 cd               write (iout,*) 'sred_geom=',sred_geom,
5158 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5159                 call calc_eello(i,j,i+1,j1,jj,kk)
5160                 if (wcorr4.gt.0.0d0)
5161      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5162                 if (wcorr5.gt.0.0d0)
5163      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5164 c                print *,"wcorr5",ecorr5
5165 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5166 cd                write(2,*)'ijkl',i,j,i+1,j1
5167                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5168      &               .or. wturn6.eq.0.0d0))then
5169 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5170                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5171 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5172 cd     &            'ecorr6=',ecorr6
5173 cd                write (iout,'(4e15.5)') sred_geom,
5174 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5175 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5176 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5177                 else if (wturn6.gt.0.0d0
5178      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5179 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5180                   eturn6=eturn6+eello_turn6(i,jj,kk)
5181 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5182                 endif
5183               ENDIF
5184 1111          continue
5185             else if (j1.eq.j) then
5186 C Contacts I-J and I-(J+1) occur simultaneously.
5187 C The system loses extra energy.
5188 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5189             endif
5190           enddo ! kk
5191           do kk=1,num_conti
5192             j1=jcont_hb(kk,i)
5193 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5194 c    &         ' jj=',jj,' kk=',kk
5195             if (j1.eq.j+1) then
5196 C Contacts I-J and (I+1)-J occur simultaneously.
5197 C The system loses extra energy.
5198 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5199             endif ! j1==j+1
5200           enddo ! kk
5201         enddo ! jj
5202       enddo ! i
5203       return
5204       end
5205 c------------------------------------------------------------------------------
5206       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5207       implicit real*8 (a-h,o-z)
5208       include 'DIMENSIONS'
5209       include 'COMMON.IOUNITS'
5210       include 'COMMON.DERIV'
5211       include 'COMMON.INTERACT'
5212       include 'COMMON.CONTACTS'
5213       double precision gx(3),gx1(3)
5214       logical lprn
5215       lprn=.false.
5216       eij=facont_hb(jj,i)
5217       ekl=facont_hb(kk,k)
5218       ees0pij=ees0p(jj,i)
5219       ees0pkl=ees0p(kk,k)
5220       ees0mij=ees0m(jj,i)
5221       ees0mkl=ees0m(kk,k)
5222       ekont=eij*ekl
5223       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5224 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5225 C Following 4 lines for diagnostics.
5226 cd    ees0pkl=0.0D0
5227 cd    ees0pij=1.0D0
5228 cd    ees0mkl=0.0D0
5229 cd    ees0mij=1.0D0
5230 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5231 c    &   ' and',k,l
5232 c     write (iout,*)'Contacts have occurred for peptide groups',
5233 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5234 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5235 C Calculate the multi-body contribution to energy.
5236       ecorr=ecorr+ekont*ees
5237       if (calc_grad) then
5238 C Calculate multi-body contributions to the gradient.
5239       do ll=1,3
5240         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5241         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5242      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5243      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5244         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5245      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5246      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5247         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5248         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5249      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5250      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5251         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5252      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5253      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5254       enddo
5255       do m=i+1,j-1
5256         do ll=1,3
5257           gradcorr(ll,m)=gradcorr(ll,m)+
5258      &     ees*ekl*gacont_hbr(ll,jj,i)-
5259      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5260      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5261         enddo
5262       enddo
5263       do m=k+1,l-1
5264         do ll=1,3
5265           gradcorr(ll,m)=gradcorr(ll,m)+
5266      &     ees*eij*gacont_hbr(ll,kk,k)-
5267      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5268      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5269         enddo
5270       enddo
5271       endif
5272       ehbcorr=ekont*ees
5273       return
5274       end
5275 C---------------------------------------------------------------------------
5276       subroutine dipole(i,j,jj)
5277       implicit real*8 (a-h,o-z)
5278       include 'DIMENSIONS'
5279       include 'DIMENSIONS.ZSCOPT'
5280       include 'COMMON.IOUNITS'
5281       include 'COMMON.CHAIN'
5282       include 'COMMON.FFIELD'
5283       include 'COMMON.DERIV'
5284       include 'COMMON.INTERACT'
5285       include 'COMMON.CONTACTS'
5286       include 'COMMON.TORSION'
5287       include 'COMMON.VAR'
5288       include 'COMMON.GEO'
5289       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5290      &  auxmat(2,2)
5291       iti1 = itortyp(itype(i+1))
5292       if (j.lt.nres-1) then
5293         itj1 = itortyp(itype(j+1))
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) 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) 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) 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) 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(2),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) 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) 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) 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) 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