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         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
3594      &   i,theta(i)*rad2deg,phii*rad2deg,
3595      &   phii1*rad2deg,ethetai
3596         etheta=etheta+ethetai
3597         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
3598         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
3599         gloc(nphi+i-2,icg)=wang*dethetai
3600       enddo
3601       return
3602       end
3603 #endif
3604 #ifdef CRYST_SC
3605 c-----------------------------------------------------------------------------
3606       subroutine esc(escloc)
3607 C Calculate the local energy of a side chain and its derivatives in the
3608 C corresponding virtual-bond valence angles THETA and the spherical angles
3609 C ALPHA and OMEGA.
3610       implicit real*8 (a-h,o-z)
3611       include 'DIMENSIONS'
3612       include 'DIMENSIONS.ZSCOPT'
3613       include 'COMMON.GEO'
3614       include 'COMMON.LOCAL'
3615       include 'COMMON.VAR'
3616       include 'COMMON.INTERACT'
3617       include 'COMMON.DERIV'
3618       include 'COMMON.CHAIN'
3619       include 'COMMON.IOUNITS'
3620       include 'COMMON.NAMES'
3621       include 'COMMON.FFIELD'
3622       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
3623      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
3624       common /sccalc/ time11,time12,time112,theti,it,nlobit
3625       delta=0.02d0*pi
3626       escloc=0.0D0
3627 c     write (iout,'(a)') 'ESC'
3628       do i=loc_start,loc_end
3629         it=itype(i)
3630         if (it.eq.10) goto 1
3631         nlobit=nlob(it)
3632 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
3633 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
3634         theti=theta(i+1)-pipol
3635         x(1)=dtan(theti)
3636         x(2)=alph(i)
3637         x(3)=omeg(i)
3638 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
3639
3640         if (x(2).gt.pi-delta) then
3641           xtemp(1)=x(1)
3642           xtemp(2)=pi-delta
3643           xtemp(3)=x(3)
3644           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3645           xtemp(2)=pi
3646           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3647           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
3648      &        escloci,dersc(2))
3649           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3650      &        ddersc0(1),dersc(1))
3651           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
3652      &        ddersc0(3),dersc(3))
3653           xtemp(2)=pi-delta
3654           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3655           xtemp(2)=pi
3656           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3657           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
3658      &            dersc0(2),esclocbi,dersc02)
3659           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3660      &            dersc12,dersc01)
3661           call splinthet(x(2),0.5d0*delta,ss,ssd)
3662           dersc0(1)=dersc01
3663           dersc0(2)=dersc02
3664           dersc0(3)=0.0d0
3665           do k=1,3
3666             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3667           enddo
3668           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3669 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3670 c    &             esclocbi,ss,ssd
3671           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3672 c         escloci=esclocbi
3673 c         write (iout,*) escloci
3674         else if (x(2).lt.delta) then
3675           xtemp(1)=x(1)
3676           xtemp(2)=delta
3677           xtemp(3)=x(3)
3678           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3679           xtemp(2)=0.0d0
3680           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3681           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
3682      &        escloci,dersc(2))
3683           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3684      &        ddersc0(1),dersc(1))
3685           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
3686      &        ddersc0(3),dersc(3))
3687           xtemp(2)=delta
3688           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3689           xtemp(2)=0.0d0
3690           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3691           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
3692      &            dersc0(2),esclocbi,dersc02)
3693           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3694      &            dersc12,dersc01)
3695           dersc0(1)=dersc01
3696           dersc0(2)=dersc02
3697           dersc0(3)=0.0d0
3698           call splinthet(x(2),0.5d0*delta,ss,ssd)
3699           do k=1,3
3700             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3701           enddo
3702           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3703 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3704 c    &             esclocbi,ss,ssd
3705           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3706 c         write (iout,*) escloci
3707         else
3708           call enesc(x,escloci,dersc,ddummy,.false.)
3709         endif
3710
3711         escloc=escloc+escloci
3712 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
3713
3714         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3715      &   wscloc*dersc(1)
3716         gloc(ialph(i,1),icg)=wscloc*dersc(2)
3717         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
3718     1   continue
3719       enddo
3720       return
3721       end
3722 C---------------------------------------------------------------------------
3723       subroutine enesc(x,escloci,dersc,ddersc,mixed)
3724       implicit real*8 (a-h,o-z)
3725       include 'DIMENSIONS'
3726       include 'COMMON.GEO'
3727       include 'COMMON.LOCAL'
3728       include 'COMMON.IOUNITS'
3729       common /sccalc/ time11,time12,time112,theti,it,nlobit
3730       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
3731       double precision contr(maxlob,-1:1)
3732       logical mixed
3733 c       write (iout,*) 'it=',it,' nlobit=',nlobit
3734         escloc_i=0.0D0
3735         do j=1,3
3736           dersc(j)=0.0D0
3737           if (mixed) ddersc(j)=0.0d0
3738         enddo
3739         x3=x(3)
3740
3741 C Because of periodicity of the dependence of the SC energy in omega we have
3742 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
3743 C To avoid underflows, first compute & store the exponents.
3744
3745         do iii=-1,1
3746
3747           x(3)=x3+iii*dwapi
3748
3749           do j=1,nlobit
3750             do k=1,3
3751               z(k)=x(k)-censc(k,j,it)
3752             enddo
3753             do k=1,3
3754               Axk=0.0D0
3755               do l=1,3
3756                 Axk=Axk+gaussc(l,k,j,it)*z(l)
3757               enddo
3758               Ax(k,j,iii)=Axk
3759             enddo
3760             expfac=0.0D0
3761             do k=1,3
3762               expfac=expfac+Ax(k,j,iii)*z(k)
3763             enddo
3764             contr(j,iii)=expfac
3765           enddo ! j
3766
3767         enddo ! iii
3768
3769         x(3)=x3
3770 C As in the case of ebend, we want to avoid underflows in exponentiation and
3771 C subsequent NaNs and INFs in energy calculation.
3772 C Find the largest exponent
3773         emin=contr(1,-1)
3774         do iii=-1,1
3775           do j=1,nlobit
3776             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
3777           enddo
3778         enddo
3779         emin=0.5D0*emin
3780 cd      print *,'it=',it,' emin=',emin
3781
3782 C Compute the contribution to SC energy and derivatives
3783         do iii=-1,1
3784
3785           do j=1,nlobit
3786             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
3787 cd          print *,'j=',j,' expfac=',expfac
3788             escloc_i=escloc_i+expfac
3789             do k=1,3
3790               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
3791             enddo
3792             if (mixed) then
3793               do k=1,3,2
3794                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
3795      &            +gaussc(k,2,j,it))*expfac
3796               enddo
3797             endif
3798           enddo
3799
3800         enddo ! iii
3801
3802         dersc(1)=dersc(1)/cos(theti)**2
3803         ddersc(1)=ddersc(1)/cos(theti)**2
3804         ddersc(3)=ddersc(3)
3805
3806         escloci=-(dlog(escloc_i)-emin)
3807         do j=1,3
3808           dersc(j)=dersc(j)/escloc_i
3809         enddo
3810         if (mixed) then
3811           do j=1,3,2
3812             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
3813           enddo
3814         endif
3815       return
3816       end
3817 C------------------------------------------------------------------------------
3818       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
3819       implicit real*8 (a-h,o-z)
3820       include 'DIMENSIONS'
3821       include 'COMMON.GEO'
3822       include 'COMMON.LOCAL'
3823       include 'COMMON.IOUNITS'
3824       common /sccalc/ time11,time12,time112,theti,it,nlobit
3825       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
3826       double precision contr(maxlob)
3827       logical mixed
3828
3829       escloc_i=0.0D0
3830
3831       do j=1,3
3832         dersc(j)=0.0D0
3833       enddo
3834
3835       do j=1,nlobit
3836         do k=1,2
3837           z(k)=x(k)-censc(k,j,it)
3838         enddo
3839         z(3)=dwapi
3840         do k=1,3
3841           Axk=0.0D0
3842           do l=1,3
3843             Axk=Axk+gaussc(l,k,j,it)*z(l)
3844           enddo
3845           Ax(k,j)=Axk
3846         enddo
3847         expfac=0.0D0
3848         do k=1,3
3849           expfac=expfac+Ax(k,j)*z(k)
3850         enddo
3851         contr(j)=expfac
3852       enddo ! j
3853
3854 C As in the case of ebend, we want to avoid underflows in exponentiation and
3855 C subsequent NaNs and INFs in energy calculation.
3856 C Find the largest exponent
3857       emin=contr(1)
3858       do j=1,nlobit
3859         if (emin.gt.contr(j)) emin=contr(j)
3860       enddo
3861       emin=0.5D0*emin
3862
3863 C Compute the contribution to SC energy and derivatives
3864
3865       dersc12=0.0d0
3866       do j=1,nlobit
3867         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
3868         escloc_i=escloc_i+expfac
3869         do k=1,2
3870           dersc(k)=dersc(k)+Ax(k,j)*expfac
3871         enddo
3872         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
3873      &            +gaussc(1,2,j,it))*expfac
3874         dersc(3)=0.0d0
3875       enddo
3876
3877       dersc(1)=dersc(1)/cos(theti)**2
3878       dersc12=dersc12/cos(theti)**2
3879       escloci=-(dlog(escloc_i)-emin)
3880       do j=1,2
3881         dersc(j)=dersc(j)/escloc_i
3882       enddo
3883       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
3884       return
3885       end
3886 #else
3887 c----------------------------------------------------------------------------------
3888       subroutine esc(escloc)
3889 C Calculate the local energy of a side chain and its derivatives in the
3890 C corresponding virtual-bond valence angles THETA and the spherical angles
3891 C ALPHA and OMEGA derived from AM1 all-atom calculations.
3892 C added by Urszula Kozlowska. 07/11/2007
3893 C
3894       implicit real*8 (a-h,o-z)
3895       include 'DIMENSIONS'
3896       include 'DIMENSIONS.ZSCOPT'
3897       include 'COMMON.GEO'
3898       include 'COMMON.LOCAL'
3899       include 'COMMON.VAR'
3900       include 'COMMON.SCROT'
3901       include 'COMMON.INTERACT'
3902       include 'COMMON.DERIV'
3903       include 'COMMON.CHAIN'
3904       include 'COMMON.IOUNITS'
3905       include 'COMMON.NAMES'
3906       include 'COMMON.FFIELD'
3907       include 'COMMON.CONTROL'
3908       include 'COMMON.VECTORS'
3909       double precision x_prime(3),y_prime(3),z_prime(3)
3910      &    , sumene,dsc_i,dp2_i,x(65),
3911      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
3912      &    de_dxx,de_dyy,de_dzz,de_dt
3913       double precision s1_t,s1_6_t,s2_t,s2_6_t
3914       double precision
3915      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
3916      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
3917      & dt_dCi(3),dt_dCi1(3)
3918       common /sccalc/ time11,time12,time112,theti,it,nlobit
3919       delta=0.02d0*pi
3920       escloc=0.0D0
3921       do i=loc_start,loc_end
3922         costtab(i+1) =dcos(theta(i+1))
3923         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
3924         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
3925         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
3926         cosfac2=0.5d0/(1.0d0+costtab(i+1))
3927         cosfac=dsqrt(cosfac2)
3928         sinfac2=0.5d0/(1.0d0-costtab(i+1))
3929         sinfac=dsqrt(sinfac2)
3930         it=itype(i)
3931         if (it.eq.10) goto 1
3932 c
3933 C  Compute the axes of tghe local cartesian coordinates system; store in
3934 c   x_prime, y_prime and z_prime
3935 c
3936         do j=1,3
3937           x_prime(j) = 0.00
3938           y_prime(j) = 0.00
3939           z_prime(j) = 0.00
3940         enddo
3941 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
3942 C     &   dc_norm(3,i+nres)
3943         do j = 1,3
3944           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
3945           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
3946         enddo
3947         do j = 1,3
3948           z_prime(j) = -uz(j,i-1)
3949         enddo
3950 c       write (2,*) "i",i
3951 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
3952 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
3953 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
3954 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
3955 c      & " xy",scalar(x_prime(1),y_prime(1)),
3956 c      & " xz",scalar(x_prime(1),z_prime(1)),
3957 c      & " yy",scalar(y_prime(1),y_prime(1)),
3958 c      & " yz",scalar(y_prime(1),z_prime(1)),
3959 c      & " zz",scalar(z_prime(1),z_prime(1))
3960 c
3961 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
3962 C to local coordinate system. Store in xx, yy, zz.
3963 c
3964         xx=0.0d0
3965         yy=0.0d0
3966         zz=0.0d0
3967         do j = 1,3
3968           xx = xx + x_prime(j)*dc_norm(j,i+nres)
3969           yy = yy + y_prime(j)*dc_norm(j,i+nres)
3970           zz = zz + z_prime(j)*dc_norm(j,i+nres)
3971         enddo
3972
3973         xxtab(i)=xx
3974         yytab(i)=yy
3975         zztab(i)=zz
3976 C
3977 C Compute the energy of the ith side cbain
3978 C
3979 c        write (2,*) "xx",xx," yy",yy," zz",zz
3980         it=itype(i)
3981         do j = 1,65
3982           x(j) = sc_parmin(j,it)
3983         enddo
3984 #ifdef CHECK_COORD
3985 Cc diagnostics - remove later
3986         xx1 = dcos(alph(2))
3987         yy1 = dsin(alph(2))*dcos(omeg(2))
3988         zz1 = -dsin(alph(2))*dsin(omeg(2))
3989         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
3990      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
3991      &    xx1,yy1,zz1
3992 C,"  --- ", xx_w,yy_w,zz_w
3993 c end diagnostics
3994 #endif
3995         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
3996      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
3997      &   + x(10)*yy*zz
3998         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
3999      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4000      & + x(20)*yy*zz
4001         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4002      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4003      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4004      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4005      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4006      &  +x(40)*xx*yy*zz
4007         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4008      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4009      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4010      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4011      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4012      &  +x(60)*xx*yy*zz
4013         dsc_i   = 0.743d0+x(61)
4014         dp2_i   = 1.9d0+x(62)
4015         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4016      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4017         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4018      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4019         s1=(1+x(63))/(0.1d0 + dscp1)
4020         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4021         s2=(1+x(65))/(0.1d0 + dscp2)
4022         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4023         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4024      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4025 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4026 c     &   sumene4,
4027 c     &   dscp1,dscp2,sumene
4028 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4029         escloc = escloc + sumene
4030 c        write (2,*) "escloc",escloc
4031         if (.not. calc_grad) goto 1
4032
4033 #ifdef DEBUG2
4034 C
4035 C This section to check the numerical derivatives of the energy of ith side
4036 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4037 C #define DEBUG in the code to turn it on.
4038 C
4039         write (2,*) "sumene               =",sumene
4040         aincr=1.0d-7
4041         xxsave=xx
4042         xx=xx+aincr
4043         write (2,*) xx,yy,zz
4044         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4045         de_dxx_num=(sumenep-sumene)/aincr
4046         xx=xxsave
4047         write (2,*) "xx+ sumene from enesc=",sumenep
4048         yysave=yy
4049         yy=yy+aincr
4050         write (2,*) xx,yy,zz
4051         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4052         de_dyy_num=(sumenep-sumene)/aincr
4053         yy=yysave
4054         write (2,*) "yy+ sumene from enesc=",sumenep
4055         zzsave=zz
4056         zz=zz+aincr
4057         write (2,*) xx,yy,zz
4058         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4059         de_dzz_num=(sumenep-sumene)/aincr
4060         zz=zzsave
4061         write (2,*) "zz+ sumene from enesc=",sumenep
4062         costsave=cost2tab(i+1)
4063         sintsave=sint2tab(i+1)
4064         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4065         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4066         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4067         de_dt_num=(sumenep-sumene)/aincr
4068         write (2,*) " t+ sumene from enesc=",sumenep
4069         cost2tab(i+1)=costsave
4070         sint2tab(i+1)=sintsave
4071 C End of diagnostics section.
4072 #endif
4073 C
4074 C Compute the gradient of esc
4075 C
4076         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4077         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4078         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4079         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4080         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4081         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4082         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4083         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4084         pom1=(sumene3*sint2tab(i+1)+sumene1)
4085      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4086         pom2=(sumene4*cost2tab(i+1)+sumene2)
4087      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4088         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4089         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4090      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4091      &  +x(40)*yy*zz
4092         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4093         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4094      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4095      &  +x(60)*yy*zz
4096         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4097      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4098      &        +(pom1+pom2)*pom_dx
4099 #ifdef DEBUG
4100         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4101 #endif
4102 C
4103         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4104         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4105      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4106      &  +x(40)*xx*zz
4107         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4108         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4109      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4110      &  +x(59)*zz**2 +x(60)*xx*zz
4111         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4112      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4113      &        +(pom1-pom2)*pom_dy
4114 #ifdef DEBUG
4115         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4116 #endif
4117 C
4118         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4119      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4120      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4121      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4122      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4123      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4124      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4125      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4126 #ifdef DEBUG
4127         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4128 #endif
4129 C
4130         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4131      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4132      &  +pom1*pom_dt1+pom2*pom_dt2
4133 #ifdef DEBUG
4134         write(2,*), "de_dt = ", de_dt,de_dt_num
4135 #endif
4136 c
4137 C
4138        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4139        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4140        cosfac2xx=cosfac2*xx
4141        sinfac2yy=sinfac2*yy
4142        do k = 1,3
4143          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4144      &      vbld_inv(i+1)
4145          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4146      &      vbld_inv(i)
4147          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4148          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4149 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4150 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4151 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4152 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4153          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4154          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4155          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4156          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4157          dZZ_Ci1(k)=0.0d0
4158          dZZ_Ci(k)=0.0d0
4159          do j=1,3
4160            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4161            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4162          enddo
4163
4164          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4165          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4166          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4167 c
4168          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4169          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4170        enddo
4171
4172        do k=1,3
4173          dXX_Ctab(k,i)=dXX_Ci(k)
4174          dXX_C1tab(k,i)=dXX_Ci1(k)
4175          dYY_Ctab(k,i)=dYY_Ci(k)
4176          dYY_C1tab(k,i)=dYY_Ci1(k)
4177          dZZ_Ctab(k,i)=dZZ_Ci(k)
4178          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4179          dXX_XYZtab(k,i)=dXX_XYZ(k)
4180          dYY_XYZtab(k,i)=dYY_XYZ(k)
4181          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4182        enddo
4183
4184        do k = 1,3
4185 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4186 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4187 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4188 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4189 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4190 c     &    dt_dci(k)
4191 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4192 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4193          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4194      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4195          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4196      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4197          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4198      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4199        enddo
4200 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4201 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4202
4203 C to check gradient call subroutine check_grad
4204
4205     1 continue
4206       enddo
4207       return
4208       end
4209 #endif
4210 c------------------------------------------------------------------------------
4211       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4212 C
4213 C This procedure calculates two-body contact function g(rij) and its derivative:
4214 C
4215 C           eps0ij                                     !       x < -1
4216 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4217 C            0                                         !       x > 1
4218 C
4219 C where x=(rij-r0ij)/delta
4220 C
4221 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4222 C
4223       implicit none
4224       double precision rij,r0ij,eps0ij,fcont,fprimcont
4225       double precision x,x2,x4,delta
4226 c     delta=0.02D0*r0ij
4227 c      delta=0.2D0*r0ij
4228       x=(rij-r0ij)/delta
4229       if (x.lt.-1.0D0) then
4230         fcont=eps0ij
4231         fprimcont=0.0D0
4232       else if (x.le.1.0D0) then
4233         x2=x*x
4234         x4=x2*x2
4235         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4236         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4237       else
4238         fcont=0.0D0
4239         fprimcont=0.0D0
4240       endif
4241       return
4242       end
4243 c------------------------------------------------------------------------------
4244       subroutine splinthet(theti,delta,ss,ssder)
4245       implicit real*8 (a-h,o-z)
4246       include 'DIMENSIONS'
4247       include 'DIMENSIONS.ZSCOPT'
4248       include 'COMMON.VAR'
4249       include 'COMMON.GEO'
4250       thetup=pi-delta
4251       thetlow=delta
4252       if (theti.gt.pipol) then
4253         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4254       else
4255         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4256         ssder=-ssder
4257       endif
4258       return
4259       end
4260 c------------------------------------------------------------------------------
4261       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4262       implicit none
4263       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4264       double precision ksi,ksi2,ksi3,a1,a2,a3
4265       a1=fprim0*delta/(f1-f0)
4266       a2=3.0d0-2.0d0*a1
4267       a3=a1-2.0d0
4268       ksi=(x-x0)/delta
4269       ksi2=ksi*ksi
4270       ksi3=ksi2*ksi
4271       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4272       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4273       return
4274       end
4275 c------------------------------------------------------------------------------
4276       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4277       implicit none
4278       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4279       double precision ksi,ksi2,ksi3,a1,a2,a3
4280       ksi=(x-x0)/delta
4281       ksi2=ksi*ksi
4282       ksi3=ksi2*ksi
4283       a1=fprim0x*delta
4284       a2=3*(f1x-f0x)-2*fprim0x*delta
4285       a3=fprim0x*delta-2*(f1x-f0x)
4286       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4287       return
4288       end
4289 C-----------------------------------------------------------------------------
4290 #ifdef CRYST_TOR
4291 C-----------------------------------------------------------------------------
4292       subroutine etor(etors,edihcnstr,fact)
4293       implicit real*8 (a-h,o-z)
4294       include 'DIMENSIONS'
4295       include 'DIMENSIONS.ZSCOPT'
4296       include 'COMMON.VAR'
4297       include 'COMMON.GEO'
4298       include 'COMMON.LOCAL'
4299       include 'COMMON.TORSION'
4300       include 'COMMON.INTERACT'
4301       include 'COMMON.DERIV'
4302       include 'COMMON.CHAIN'
4303       include 'COMMON.NAMES'
4304       include 'COMMON.IOUNITS'
4305       include 'COMMON.FFIELD'
4306       include 'COMMON.TORCNSTR'
4307       logical lprn
4308 C Set lprn=.true. for debugging
4309       lprn=.false.
4310 c      lprn=.true.
4311       etors=0.0D0
4312       do i=iphi_start,iphi_end
4313         itori=itortyp(itype(i-2))
4314         itori1=itortyp(itype(i-1))
4315         phii=phi(i)
4316         gloci=0.0D0
4317 C Proline-Proline pair is a special case...
4318         if (itori.eq.3 .and. itori1.eq.3) then
4319           if (phii.gt.-dwapi3) then
4320             cosphi=dcos(3*phii)
4321             fac=1.0D0/(1.0D0-cosphi)
4322             etorsi=v1(1,3,3)*fac
4323             etorsi=etorsi+etorsi
4324             etors=etors+etorsi-v1(1,3,3)
4325             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4326           endif
4327           do j=1,3
4328             v1ij=v1(j+1,itori,itori1)
4329             v2ij=v2(j+1,itori,itori1)
4330             cosphi=dcos(j*phii)
4331             sinphi=dsin(j*phii)
4332             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4333             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4334           enddo
4335         else
4336           do j=1,nterm_old
4337             v1ij=v1(j,itori,itori1)
4338             v2ij=v2(j,itori,itori1)
4339             cosphi=dcos(j*phii)
4340             sinphi=dsin(j*phii)
4341             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4342             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4343           enddo
4344         endif
4345         if (lprn)
4346      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4347      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4348      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4349         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4350 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4351       enddo
4352 ! 6/20/98 - dihedral angle constraints
4353       edihcnstr=0.0d0
4354       do i=1,ndih_constr
4355         itori=idih_constr(i)
4356         phii=phi(itori)
4357         difi=phii-phi0(i)
4358         if (difi.gt.drange(i)) then
4359           difi=difi-drange(i)
4360           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4361           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4362         else if (difi.lt.-drange(i)) then
4363           difi=difi+drange(i)
4364           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4365           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4366         endif
4367 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4368 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4369       enddo
4370 !      write (iout,*) 'edihcnstr',edihcnstr
4371       return
4372       end
4373 c------------------------------------------------------------------------------
4374 #else
4375       subroutine etor(etors,edihcnstr,fact)
4376       implicit real*8 (a-h,o-z)
4377       include 'DIMENSIONS'
4378       include 'DIMENSIONS.ZSCOPT'
4379       include 'COMMON.VAR'
4380       include 'COMMON.GEO'
4381       include 'COMMON.LOCAL'
4382       include 'COMMON.TORSION'
4383       include 'COMMON.INTERACT'
4384       include 'COMMON.DERIV'
4385       include 'COMMON.CHAIN'
4386       include 'COMMON.NAMES'
4387       include 'COMMON.IOUNITS'
4388       include 'COMMON.FFIELD'
4389       include 'COMMON.TORCNSTR'
4390       logical lprn
4391 C Set lprn=.true. for debugging
4392       lprn=.false.
4393 c      lprn=.true.
4394       etors=0.0D0
4395       do i=iphi_start,iphi_end
4396         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
4397         itori=itortyp(itype(i-2))
4398         itori1=itortyp(itype(i-1))
4399         phii=phi(i)
4400         gloci=0.0D0
4401 C Regular cosine and sine terms
4402         do j=1,nterm(itori,itori1)
4403           v1ij=v1(j,itori,itori1)
4404           v2ij=v2(j,itori,itori1)
4405           cosphi=dcos(j*phii)
4406           sinphi=dsin(j*phii)
4407           etors=etors+v1ij*cosphi+v2ij*sinphi
4408           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4409         enddo
4410 C Lorentz terms
4411 C                         v1
4412 C  E = SUM ----------------------------------- - v1
4413 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4414 C
4415         cosphi=dcos(0.5d0*phii)
4416         sinphi=dsin(0.5d0*phii)
4417         do j=1,nlor(itori,itori1)
4418           vl1ij=vlor1(j,itori,itori1)
4419           vl2ij=vlor2(j,itori,itori1)
4420           vl3ij=vlor3(j,itori,itori1)
4421           pom=vl2ij*cosphi+vl3ij*sinphi
4422           pom1=1.0d0/(pom*pom+1.0d0)
4423           etors=etors+vl1ij*pom1
4424           pom=-pom*pom1*pom1
4425           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4426         enddo
4427 C Subtract the constant term
4428         etors=etors-v0(itori,itori1)
4429         if (lprn)
4430      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4431      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4432      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4433         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
4434 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4435  1215   continue
4436       enddo
4437 ! 6/20/98 - dihedral angle constraints
4438       edihcnstr=0.0d0
4439       do i=1,ndih_constr
4440         itori=idih_constr(i)
4441         phii=phi(itori)
4442         difi=pinorm(phii-phi0(i))
4443         edihi=0.0d0
4444         if (difi.gt.drange(i)) then
4445           difi=difi-drange(i)
4446           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4447           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4448           edihi=0.25d0*ftors*difi**4
4449         else if (difi.lt.-drange(i)) then
4450           difi=difi+drange(i)
4451           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4452           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4453           edihi=0.25d0*ftors*difi**4
4454         else
4455           difi=0.0d0
4456         endif
4457 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
4458 c     &    drange(i),edihi
4459 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4460 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4461       enddo
4462 !      write (iout,*) 'edihcnstr',edihcnstr
4463       return
4464       end
4465 c----------------------------------------------------------------------------
4466       subroutine etor_d(etors_d,fact2)
4467 C 6/23/01 Compute double torsional energy
4468       implicit real*8 (a-h,o-z)
4469       include 'DIMENSIONS'
4470       include 'DIMENSIONS.ZSCOPT'
4471       include 'COMMON.VAR'
4472       include 'COMMON.GEO'
4473       include 'COMMON.LOCAL'
4474       include 'COMMON.TORSION'
4475       include 'COMMON.INTERACT'
4476       include 'COMMON.DERIV'
4477       include 'COMMON.CHAIN'
4478       include 'COMMON.NAMES'
4479       include 'COMMON.IOUNITS'
4480       include 'COMMON.FFIELD'
4481       include 'COMMON.TORCNSTR'
4482       logical lprn
4483 C Set lprn=.true. for debugging
4484       lprn=.false.
4485 c     lprn=.true.
4486       etors_d=0.0D0
4487       do i=iphi_start,iphi_end-1
4488         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
4489      &     goto 1215
4490         itori=itortyp(itype(i-2))
4491         itori1=itortyp(itype(i-1))
4492         itori2=itortyp(itype(i))
4493         phii=phi(i)
4494         phii1=phi(i+1)
4495         gloci1=0.0D0
4496         gloci2=0.0D0
4497 C Regular cosine and sine terms
4498         do j=1,ntermd_1(itori,itori1,itori2)
4499           v1cij=v1c(1,j,itori,itori1,itori2)
4500           v1sij=v1s(1,j,itori,itori1,itori2)
4501           v2cij=v1c(2,j,itori,itori1,itori2)
4502           v2sij=v1s(2,j,itori,itori1,itori2)
4503           cosphi1=dcos(j*phii)
4504           sinphi1=dsin(j*phii)
4505           cosphi2=dcos(j*phii1)
4506           sinphi2=dsin(j*phii1)
4507           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
4508      &     v2cij*cosphi2+v2sij*sinphi2
4509           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
4510           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
4511         enddo
4512         do k=2,ntermd_2(itori,itori1,itori2)
4513           do l=1,k-1
4514             v1cdij = v2c(k,l,itori,itori1,itori2)
4515             v2cdij = v2c(l,k,itori,itori1,itori2)
4516             v1sdij = v2s(k,l,itori,itori1,itori2)
4517             v2sdij = v2s(l,k,itori,itori1,itori2)
4518             cosphi1p2=dcos(l*phii+(k-l)*phii1)
4519             cosphi1m2=dcos(l*phii-(k-l)*phii1)
4520             sinphi1p2=dsin(l*phii+(k-l)*phii1)
4521             sinphi1m2=dsin(l*phii-(k-l)*phii1)
4522             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
4523      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
4524             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
4525      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
4526             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
4527      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
4528           enddo
4529         enddo
4530         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
4531         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
4532  1215   continue
4533       enddo
4534       return
4535       end
4536 #endif
4537 c------------------------------------------------------------------------------
4538       subroutine eback_sc_corr(esccor)
4539 c 7/21/2007 Correlations between the backbone-local and side-chain-local
4540 c        conformational states; temporarily implemented as differences
4541 c        between UNRES torsional potentials (dependent on three types of
4542 c        residues) and the torsional potentials dependent on all 20 types
4543 c        of residues computed from AM1 energy surfaces of terminally-blocked
4544 c        amino-acid residues.
4545       implicit real*8 (a-h,o-z)
4546       include 'DIMENSIONS'
4547       include 'DIMENSIONS.ZSCOPT'
4548       include 'COMMON.VAR'
4549       include 'COMMON.GEO'
4550       include 'COMMON.LOCAL'
4551       include 'COMMON.TORSION'
4552       include 'COMMON.SCCOR'
4553       include 'COMMON.INTERACT'
4554       include 'COMMON.DERIV'
4555       include 'COMMON.CHAIN'
4556       include 'COMMON.NAMES'
4557       include 'COMMON.IOUNITS'
4558       include 'COMMON.FFIELD'
4559       include 'COMMON.CONTROL'
4560       logical lprn
4561 C Set lprn=.true. for debugging
4562       lprn=.false.
4563 c      lprn=.true.
4564 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end,nterm_sccor
4565       esccor=0.0D0
4566       do i=itau_start,itau_end
4567         esccor_ii=0.0D0
4568         isccori=isccortyp(itype(i-2))
4569         isccori1=isccortyp(itype(i-1))
4570         phii=phi(i)
4571 cccc  Added 9 May 2012
4572 cc Tauangle is torsional engle depending on the value of first digit
4573 c(see comment below)
4574 cc Omicron is flat angle depending on the value of first digit
4575 c(see comment below)
4576
4577
4578         do intertyp=1,3 !intertyp
4579 cc Added 09 May 2012 (Adasko)
4580 cc  Intertyp means interaction type of backbone mainchain correlation:
4581 c   1 = SC...Ca...Ca...Ca
4582 c   2 = Ca...Ca...Ca...SC
4583 c   3 = SC...Ca...Ca...SCi
4584         gloci=0.0D0
4585         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
4586      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
4587      &      (itype(i-1).eq.21)))
4588      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
4589      &     .or.(itype(i-2).eq.21)))
4590      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
4591      &      (itype(i-1).eq.21)))) cycle
4592         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
4593         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
4594      & cycle
4595         do j=1,nterm_sccor(isccori,isccori1)
4596           v1ij=v1sccor(j,intertyp,isccori,isccori1)
4597           v2ij=v2sccor(j,intertyp,isccori,isccori1)
4598           cosphi=dcos(j*tauangle(intertyp,i))
4599           sinphi=dsin(j*tauangle(intertyp,i))
4600           esccor=esccor+v1ij*cosphi+v2ij*sinphi
4601           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4602         enddo
4603         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
4604 c       write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
4605 c     &gloc_sc(intertyp,i-3,icg)
4606         if (lprn)
4607      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4608      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4609      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
4610      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
4611         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
4612        enddo !intertyp
4613       enddo
4614 c        do i=1,nres
4615 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
4616 c        enddo
4617       return
4618       end
4619 c------------------------------------------------------------------------------
4620       subroutine multibody(ecorr)
4621 C This subroutine calculates multi-body contributions to energy following
4622 C the idea of Skolnick et al. If side chains I and J make a contact and
4623 C at the same time side chains I+1 and J+1 make a contact, an extra
4624 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
4625       implicit real*8 (a-h,o-z)
4626       include 'DIMENSIONS'
4627       include 'COMMON.IOUNITS'
4628       include 'COMMON.DERIV'
4629       include 'COMMON.INTERACT'
4630       include 'COMMON.CONTACTS'
4631       double precision gx(3),gx1(3)
4632       logical lprn
4633
4634 C Set lprn=.true. for debugging
4635       lprn=.false.
4636
4637       if (lprn) then
4638         write (iout,'(a)') 'Contact function values:'
4639         do i=nnt,nct-2
4640           write (iout,'(i2,20(1x,i2,f10.5))')
4641      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
4642         enddo
4643       endif
4644       ecorr=0.0D0
4645       do i=nnt,nct
4646         do j=1,3
4647           gradcorr(j,i)=0.0D0
4648           gradxorr(j,i)=0.0D0
4649         enddo
4650       enddo
4651       do i=nnt,nct-2
4652
4653         DO ISHIFT = 3,4
4654
4655         i1=i+ishift
4656         num_conti=num_cont(i)
4657         num_conti1=num_cont(i1)
4658         do jj=1,num_conti
4659           j=jcont(jj,i)
4660           do kk=1,num_conti1
4661             j1=jcont(kk,i1)
4662             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
4663 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4664 cd   &                   ' ishift=',ishift
4665 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
4666 C The system gains extra energy.
4667               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
4668             endif   ! j1==j+-ishift
4669           enddo     ! kk
4670         enddo       ! jj
4671
4672         ENDDO ! ISHIFT
4673
4674       enddo         ! i
4675       return
4676       end
4677 c------------------------------------------------------------------------------
4678       double precision function esccorr(i,j,k,l,jj,kk)
4679       implicit real*8 (a-h,o-z)
4680       include 'DIMENSIONS'
4681       include 'COMMON.IOUNITS'
4682       include 'COMMON.DERIV'
4683       include 'COMMON.INTERACT'
4684       include 'COMMON.CONTACTS'
4685       double precision gx(3),gx1(3)
4686       logical lprn
4687       lprn=.false.
4688       eij=facont(jj,i)
4689       ekl=facont(kk,k)
4690 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
4691 C Calculate the multi-body contribution to energy.
4692 C Calculate multi-body contributions to the gradient.
4693 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
4694 cd   & k,l,(gacont(m,kk,k),m=1,3)
4695       do m=1,3
4696         gx(m) =ekl*gacont(m,jj,i)
4697         gx1(m)=eij*gacont(m,kk,k)
4698         gradxorr(m,i)=gradxorr(m,i)-gx(m)
4699         gradxorr(m,j)=gradxorr(m,j)+gx(m)
4700         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
4701         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
4702       enddo
4703       do m=i,j-1
4704         do ll=1,3
4705           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
4706         enddo
4707       enddo
4708       do m=k,l-1
4709         do ll=1,3
4710           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
4711         enddo
4712       enddo
4713       esccorr=-eij*ekl
4714       return
4715       end
4716 c------------------------------------------------------------------------------
4717 #ifdef MPL
4718       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
4719       implicit real*8 (a-h,o-z)
4720       include 'DIMENSIONS'
4721       integer dimen1,dimen2,atom,indx
4722       double precision buffer(dimen1,dimen2)
4723       double precision zapas
4724       common /contacts_hb/ zapas(3,20,maxres,7),
4725      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4726      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4727       num_kont=num_cont_hb(atom)
4728       do i=1,num_kont
4729         do k=1,7
4730           do j=1,3
4731             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
4732           enddo ! j
4733         enddo ! k
4734         buffer(i,indx+22)=facont_hb(i,atom)
4735         buffer(i,indx+23)=ees0p(i,atom)
4736         buffer(i,indx+24)=ees0m(i,atom)
4737         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
4738       enddo ! i
4739       buffer(1,indx+26)=dfloat(num_kont)
4740       return
4741       end
4742 c------------------------------------------------------------------------------
4743       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
4744       implicit real*8 (a-h,o-z)
4745       include 'DIMENSIONS'
4746       integer dimen1,dimen2,atom,indx
4747       double precision buffer(dimen1,dimen2)
4748       double precision zapas
4749       common /contacts_hb/ zapas(3,20,maxres,7),
4750      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4751      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4752       num_kont=buffer(1,indx+26)
4753       num_kont_old=num_cont_hb(atom)
4754       num_cont_hb(atom)=num_kont+num_kont_old
4755       do i=1,num_kont
4756         ii=i+num_kont_old
4757         do k=1,7
4758           do j=1,3
4759             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
4760           enddo ! j
4761         enddo ! k
4762         facont_hb(ii,atom)=buffer(i,indx+22)
4763         ees0p(ii,atom)=buffer(i,indx+23)
4764         ees0m(ii,atom)=buffer(i,indx+24)
4765         jcont_hb(ii,atom)=buffer(i,indx+25)
4766       enddo ! i
4767       return
4768       end
4769 c------------------------------------------------------------------------------
4770 #endif
4771       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
4772 C This subroutine calculates multi-body contributions to hydrogen-bonding
4773       implicit real*8 (a-h,o-z)
4774       include 'DIMENSIONS'
4775       include 'DIMENSIONS.ZSCOPT'
4776       include 'COMMON.IOUNITS'
4777 #ifdef MPL
4778       include 'COMMON.INFO'
4779 #endif
4780       include 'COMMON.FFIELD'
4781       include 'COMMON.DERIV'
4782       include 'COMMON.INTERACT'
4783       include 'COMMON.CONTACTS'
4784 #ifdef MPL
4785       parameter (max_cont=maxconts)
4786       parameter (max_dim=2*(8*3+2))
4787       parameter (msglen1=max_cont*max_dim*4)
4788       parameter (msglen2=2*msglen1)
4789       integer source,CorrelType,CorrelID,Error
4790       double precision buffer(max_cont,max_dim)
4791 #endif
4792       double precision gx(3),gx1(3)
4793       logical lprn,ldone
4794
4795 C Set lprn=.true. for debugging
4796       lprn=.false.
4797 #ifdef MPL
4798       n_corr=0
4799       n_corr1=0
4800       if (fgProcs.le.1) goto 30
4801       if (lprn) then
4802         write (iout,'(a)') 'Contact function values:'
4803         do i=nnt,nct-2
4804           write (iout,'(2i3,50(1x,i2,f5.2))')
4805      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4806      &    j=1,num_cont_hb(i))
4807         enddo
4808       endif
4809 C Caution! Following code assumes that electrostatic interactions concerning
4810 C a given atom are split among at most two processors!
4811       CorrelType=477
4812       CorrelID=MyID+1
4813       ldone=.false.
4814       do i=1,max_cont
4815         do j=1,max_dim
4816           buffer(i,j)=0.0D0
4817         enddo
4818       enddo
4819       mm=mod(MyRank,2)
4820 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
4821       if (mm) 20,20,10
4822    10 continue
4823 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
4824       if (MyRank.gt.0) then
4825 C Send correlation contributions to the preceding processor
4826         msglen=msglen1
4827         nn=num_cont_hb(iatel_s)
4828         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
4829 cd      write (iout,*) 'The BUFFER array:'
4830 cd      do i=1,nn
4831 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
4832 cd      enddo
4833         if (ielstart(iatel_s).gt.iatel_s+ispp) then
4834           msglen=msglen2
4835             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
4836 C Clear the contacts of the atom passed to the neighboring processor
4837         nn=num_cont_hb(iatel_s+1)
4838 cd      do i=1,nn
4839 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
4840 cd      enddo
4841             num_cont_hb(iatel_s)=0
4842         endif
4843 cd      write (iout,*) 'Processor ',MyID,MyRank,
4844 cd   & ' is sending correlation contribution to processor',MyID-1,
4845 cd   & ' msglen=',msglen
4846 cd      write (*,*) 'Processor ',MyID,MyRank,
4847 cd   & ' is sending correlation contribution to processor',MyID-1,
4848 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4849         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
4850 cd      write (iout,*) 'Processor ',MyID,
4851 cd   & ' has sent correlation contribution to processor',MyID-1,
4852 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4853 cd      write (*,*) 'Processor ',MyID,
4854 cd   & ' has sent correlation contribution to processor',MyID-1,
4855 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4856         msglen=msglen1
4857       endif ! (MyRank.gt.0)
4858       if (ldone) goto 30
4859       ldone=.true.
4860    20 continue
4861 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
4862       if (MyRank.lt.fgProcs-1) then
4863 C Receive correlation contributions from the next processor
4864         msglen=msglen1
4865         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
4866 cd      write (iout,*) 'Processor',MyID,
4867 cd   & ' is receiving correlation contribution from processor',MyID+1,
4868 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4869 cd      write (*,*) 'Processor',MyID,
4870 cd   & ' is receiving correlation contribution from processor',MyID+1,
4871 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4872         nbytes=-1
4873         do while (nbytes.le.0)
4874           call mp_probe(MyID+1,CorrelType,nbytes)
4875         enddo
4876 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
4877         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
4878 cd      write (iout,*) 'Processor',MyID,
4879 cd   & ' has received correlation contribution from processor',MyID+1,
4880 cd   & ' msglen=',msglen,' nbytes=',nbytes
4881 cd      write (iout,*) 'The received BUFFER array:'
4882 cd      do i=1,max_cont
4883 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
4884 cd      enddo
4885         if (msglen.eq.msglen1) then
4886           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
4887         else if (msglen.eq.msglen2)  then
4888           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
4889           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
4890         else
4891           write (iout,*)
4892      & 'ERROR!!!! message length changed while processing correlations.'
4893           write (*,*)
4894      & 'ERROR!!!! message length changed while processing correlations.'
4895           call mp_stopall(Error)
4896         endif ! msglen.eq.msglen1
4897       endif ! MyRank.lt.fgProcs-1
4898       if (ldone) goto 30
4899       ldone=.true.
4900       goto 10
4901    30 continue
4902 #endif
4903       if (lprn) then
4904         write (iout,'(a)') 'Contact function values:'
4905         do i=nnt,nct-2
4906           write (iout,'(2i3,50(1x,i2,f5.2))')
4907      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4908      &    j=1,num_cont_hb(i))
4909         enddo
4910       endif
4911       ecorr=0.0D0
4912 C Remove the loop below after debugging !!!
4913       do i=nnt,nct
4914         do j=1,3
4915           gradcorr(j,i)=0.0D0
4916           gradxorr(j,i)=0.0D0
4917         enddo
4918       enddo
4919 C Calculate the local-electrostatic correlation terms
4920       do i=iatel_s,iatel_e+1
4921         i1=i+1
4922         num_conti=num_cont_hb(i)
4923         num_conti1=num_cont_hb(i+1)
4924         do jj=1,num_conti
4925           j=jcont_hb(jj,i)
4926           do kk=1,num_conti1
4927             j1=jcont_hb(kk,i1)
4928 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4929 c     &         ' jj=',jj,' kk=',kk
4930             if (j1.eq.j+1 .or. j1.eq.j-1) then
4931 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
4932 C The system gains extra energy.
4933               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
4934               n_corr=n_corr+1
4935             else if (j1.eq.j) then
4936 C Contacts I-J and I-(J+1) occur simultaneously.
4937 C The system loses extra energy.
4938 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
4939             endif
4940           enddo ! kk
4941           do kk=1,num_conti
4942             j1=jcont_hb(kk,i)
4943 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4944 c    &         ' jj=',jj,' kk=',kk
4945             if (j1.eq.j+1) then
4946 C Contacts I-J and (I+1)-J occur simultaneously.
4947 C The system loses extra energy.
4948 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
4949             endif ! j1==j+1
4950           enddo ! kk
4951         enddo ! jj
4952       enddo ! i
4953       return
4954       end
4955 c------------------------------------------------------------------------------
4956       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
4957      &  n_corr1)
4958 C This subroutine calculates multi-body contributions to hydrogen-bonding
4959       implicit real*8 (a-h,o-z)
4960       include 'DIMENSIONS'
4961       include 'DIMENSIONS.ZSCOPT'
4962       include 'COMMON.IOUNITS'
4963 #ifdef MPL
4964       include 'COMMON.INFO'
4965 #endif
4966       include 'COMMON.FFIELD'
4967       include 'COMMON.DERIV'
4968       include 'COMMON.INTERACT'
4969       include 'COMMON.CONTACTS'
4970 #ifdef MPL
4971       parameter (max_cont=maxconts)
4972       parameter (max_dim=2*(8*3+2))
4973       parameter (msglen1=max_cont*max_dim*4)
4974       parameter (msglen2=2*msglen1)
4975       integer source,CorrelType,CorrelID,Error
4976       double precision buffer(max_cont,max_dim)
4977 #endif
4978       double precision gx(3),gx1(3)
4979       logical lprn,ldone
4980
4981 C Set lprn=.true. for debugging
4982       lprn=.false.
4983       eturn6=0.0d0
4984 #ifdef MPL
4985       n_corr=0
4986       n_corr1=0
4987       if (fgProcs.le.1) goto 30
4988       if (lprn) then
4989         write (iout,'(a)') 'Contact function values:'
4990         do i=nnt,nct-2
4991           write (iout,'(2i3,50(1x,i2,f5.2))')
4992      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4993      &    j=1,num_cont_hb(i))
4994         enddo
4995       endif
4996 C Caution! Following code assumes that electrostatic interactions concerning
4997 C a given atom are split among at most two processors!
4998       CorrelType=477
4999       CorrelID=MyID+1
5000       ldone=.false.
5001       do i=1,max_cont
5002         do j=1,max_dim
5003           buffer(i,j)=0.0D0
5004         enddo
5005       enddo
5006       mm=mod(MyRank,2)
5007 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5008       if (mm) 20,20,10
5009    10 continue
5010 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5011       if (MyRank.gt.0) then
5012 C Send correlation contributions to the preceding processor
5013         msglen=msglen1
5014         nn=num_cont_hb(iatel_s)
5015         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5016 cd      write (iout,*) 'The BUFFER array:'
5017 cd      do i=1,nn
5018 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5019 cd      enddo
5020         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5021           msglen=msglen2
5022             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5023 C Clear the contacts of the atom passed to the neighboring processor
5024         nn=num_cont_hb(iatel_s+1)
5025 cd      do i=1,nn
5026 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5027 cd      enddo
5028             num_cont_hb(iatel_s)=0
5029         endif
5030 cd      write (iout,*) 'Processor ',MyID,MyRank,
5031 cd   & ' is sending correlation contribution to processor',MyID-1,
5032 cd   & ' msglen=',msglen
5033 cd      write (*,*) 'Processor ',MyID,MyRank,
5034 cd   & ' is sending correlation contribution to processor',MyID-1,
5035 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5036         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5037 cd      write (iout,*) 'Processor ',MyID,
5038 cd   & ' has sent correlation contribution to processor',MyID-1,
5039 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5040 cd      write (*,*) 'Processor ',MyID,
5041 cd   & ' has sent correlation contribution to processor',MyID-1,
5042 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5043         msglen=msglen1
5044       endif ! (MyRank.gt.0)
5045       if (ldone) goto 30
5046       ldone=.true.
5047    20 continue
5048 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5049       if (MyRank.lt.fgProcs-1) then
5050 C Receive correlation contributions from the next processor
5051         msglen=msglen1
5052         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5053 cd      write (iout,*) 'Processor',MyID,
5054 cd   & ' is receiving correlation contribution from processor',MyID+1,
5055 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5056 cd      write (*,*) 'Processor',MyID,
5057 cd   & ' is receiving correlation contribution from processor',MyID+1,
5058 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5059         nbytes=-1
5060         do while (nbytes.le.0)
5061           call mp_probe(MyID+1,CorrelType,nbytes)
5062         enddo
5063 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5064         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5065 cd      write (iout,*) 'Processor',MyID,
5066 cd   & ' has received correlation contribution from processor',MyID+1,
5067 cd   & ' msglen=',msglen,' nbytes=',nbytes
5068 cd      write (iout,*) 'The received BUFFER array:'
5069 cd      do i=1,max_cont
5070 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5071 cd      enddo
5072         if (msglen.eq.msglen1) then
5073           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5074         else if (msglen.eq.msglen2)  then
5075           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5076           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5077         else
5078           write (iout,*)
5079      & 'ERROR!!!! message length changed while processing correlations.'
5080           write (*,*)
5081      & 'ERROR!!!! message length changed while processing correlations.'
5082           call mp_stopall(Error)
5083         endif ! msglen.eq.msglen1
5084       endif ! MyRank.lt.fgProcs-1
5085       if (ldone) goto 30
5086       ldone=.true.
5087       goto 10
5088    30 continue
5089 #endif
5090       if (lprn) then
5091         write (iout,'(a)') 'Contact function values:'
5092         do i=nnt,nct-2
5093           write (iout,'(2i3,50(1x,i2,f5.2))')
5094      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5095      &    j=1,num_cont_hb(i))
5096         enddo
5097       endif
5098       ecorr=0.0D0
5099       ecorr5=0.0d0
5100       ecorr6=0.0d0
5101 C Remove the loop below after debugging !!!
5102       do i=nnt,nct
5103         do j=1,3
5104           gradcorr(j,i)=0.0D0
5105           gradxorr(j,i)=0.0D0
5106         enddo
5107       enddo
5108 C Calculate the dipole-dipole interaction energies
5109       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5110       do i=iatel_s,iatel_e+1
5111         num_conti=num_cont_hb(i)
5112         do jj=1,num_conti
5113           j=jcont_hb(jj,i)
5114           call dipole(i,j,jj)
5115         enddo
5116       enddo
5117       endif
5118 C Calculate the local-electrostatic correlation terms
5119       do i=iatel_s,iatel_e+1
5120         i1=i+1
5121         num_conti=num_cont_hb(i)
5122         num_conti1=num_cont_hb(i+1)
5123         do jj=1,num_conti
5124           j=jcont_hb(jj,i)
5125           do kk=1,num_conti1
5126             j1=jcont_hb(kk,i1)
5127 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5128 c     &         ' jj=',jj,' kk=',kk
5129             if (j1.eq.j+1 .or. j1.eq.j-1) then
5130 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5131 C The system gains extra energy.
5132               n_corr=n_corr+1
5133               sqd1=dsqrt(d_cont(jj,i))
5134               sqd2=dsqrt(d_cont(kk,i1))
5135               sred_geom = sqd1*sqd2
5136               IF (sred_geom.lt.cutoff_corr) THEN
5137                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5138      &            ekont,fprimcont)
5139 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5140 c     &         ' jj=',jj,' kk=',kk
5141                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5142                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5143                 do l=1,3
5144                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5145                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5146                 enddo
5147                 n_corr1=n_corr1+1
5148 cd               write (iout,*) 'sred_geom=',sred_geom,
5149 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5150                 call calc_eello(i,j,i+1,j1,jj,kk)
5151                 if (wcorr4.gt.0.0d0)
5152      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5153                 if (wcorr5.gt.0.0d0)
5154      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5155 c                print *,"wcorr5",ecorr5
5156 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5157 cd                write(2,*)'ijkl',i,j,i+1,j1
5158                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5159      &               .or. wturn6.eq.0.0d0))then
5160 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5161                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5162 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5163 cd     &            'ecorr6=',ecorr6
5164 cd                write (iout,'(4e15.5)') sred_geom,
5165 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5166 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5167 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5168                 else if (wturn6.gt.0.0d0
5169      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5170 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5171                   eturn6=eturn6+eello_turn6(i,jj,kk)
5172 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5173                 endif
5174               ENDIF
5175 1111          continue
5176             else if (j1.eq.j) then
5177 C Contacts I-J and I-(J+1) occur simultaneously.
5178 C The system loses extra energy.
5179 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5180             endif
5181           enddo ! kk
5182           do kk=1,num_conti
5183             j1=jcont_hb(kk,i)
5184 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5185 c    &         ' jj=',jj,' kk=',kk
5186             if (j1.eq.j+1) then
5187 C Contacts I-J and (I+1)-J occur simultaneously.
5188 C The system loses extra energy.
5189 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5190             endif ! j1==j+1
5191           enddo ! kk
5192         enddo ! jj
5193       enddo ! i
5194       return
5195       end
5196 c------------------------------------------------------------------------------
5197       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5198       implicit real*8 (a-h,o-z)
5199       include 'DIMENSIONS'
5200       include 'COMMON.IOUNITS'
5201       include 'COMMON.DERIV'
5202       include 'COMMON.INTERACT'
5203       include 'COMMON.CONTACTS'
5204       double precision gx(3),gx1(3)
5205       logical lprn
5206       lprn=.false.
5207       eij=facont_hb(jj,i)
5208       ekl=facont_hb(kk,k)
5209       ees0pij=ees0p(jj,i)
5210       ees0pkl=ees0p(kk,k)
5211       ees0mij=ees0m(jj,i)
5212       ees0mkl=ees0m(kk,k)
5213       ekont=eij*ekl
5214       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5215 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5216 C Following 4 lines for diagnostics.
5217 cd    ees0pkl=0.0D0
5218 cd    ees0pij=1.0D0
5219 cd    ees0mkl=0.0D0
5220 cd    ees0mij=1.0D0
5221 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5222 c    &   ' and',k,l
5223 c     write (iout,*)'Contacts have occurred for peptide groups',
5224 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5225 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5226 C Calculate the multi-body contribution to energy.
5227       ecorr=ecorr+ekont*ees
5228       if (calc_grad) then
5229 C Calculate multi-body contributions to the gradient.
5230       do ll=1,3
5231         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5232         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5233      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5234      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5235         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5236      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5237      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5238         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5239         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5240      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5241      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5242         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5243      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5244      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5245       enddo
5246       do m=i+1,j-1
5247         do ll=1,3
5248           gradcorr(ll,m)=gradcorr(ll,m)+
5249      &     ees*ekl*gacont_hbr(ll,jj,i)-
5250      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5251      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5252         enddo
5253       enddo
5254       do m=k+1,l-1
5255         do ll=1,3
5256           gradcorr(ll,m)=gradcorr(ll,m)+
5257      &     ees*eij*gacont_hbr(ll,kk,k)-
5258      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5259      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5260         enddo
5261       enddo
5262       endif
5263       ehbcorr=ekont*ees
5264       return
5265       end
5266 C---------------------------------------------------------------------------
5267       subroutine dipole(i,j,jj)
5268       implicit real*8 (a-h,o-z)
5269       include 'DIMENSIONS'
5270       include 'DIMENSIONS.ZSCOPT'
5271       include 'COMMON.IOUNITS'
5272       include 'COMMON.CHAIN'
5273       include 'COMMON.FFIELD'
5274       include 'COMMON.DERIV'
5275       include 'COMMON.INTERACT'
5276       include 'COMMON.CONTACTS'
5277       include 'COMMON.TORSION'
5278       include 'COMMON.VAR'
5279       include 'COMMON.GEO'
5280       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5281      &  auxmat(2,2)
5282       iti1 = itortyp(itype(i+1))
5283       if (j.lt.nres-1) then
5284         itj1 = itortyp(itype(j+1))
5285       else
5286         itj1=ntortyp+1
5287       endif
5288       do iii=1,2
5289         dipi(iii,1)=Ub2(iii,i)
5290         dipderi(iii)=Ub2der(iii,i)
5291         dipi(iii,2)=b1(iii,iti1)
5292         dipj(iii,1)=Ub2(iii,j)
5293         dipderj(iii)=Ub2der(iii,j)
5294         dipj(iii,2)=b1(iii,itj1)
5295       enddo
5296       kkk=0
5297       do iii=1,2
5298         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5299         do jjj=1,2
5300           kkk=kkk+1
5301           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5302         enddo
5303       enddo
5304       if (.not.calc_grad) return
5305       do kkk=1,5
5306         do lll=1,3
5307           mmm=0
5308           do iii=1,2
5309             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5310      &        auxvec(1))
5311             do jjj=1,2
5312               mmm=mmm+1
5313               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5314             enddo
5315           enddo
5316         enddo
5317       enddo
5318       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5319       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5320       do iii=1,2
5321         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5322       enddo
5323       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5324       do iii=1,2
5325         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5326       enddo
5327       return
5328       end
5329 C---------------------------------------------------------------------------
5330       subroutine calc_eello(i,j,k,l,jj,kk)
5331 C
5332 C This subroutine computes matrices and vectors needed to calculate
5333 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5334 C
5335       implicit real*8 (a-h,o-z)
5336       include 'DIMENSIONS'
5337       include 'DIMENSIONS.ZSCOPT'
5338       include 'COMMON.IOUNITS'
5339       include 'COMMON.CHAIN'
5340       include 'COMMON.DERIV'
5341       include 'COMMON.INTERACT'
5342       include 'COMMON.CONTACTS'
5343       include 'COMMON.TORSION'
5344       include 'COMMON.VAR'
5345       include 'COMMON.GEO'
5346       include 'COMMON.FFIELD'
5347       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5348      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5349       logical lprn
5350       common /kutas/ lprn
5351 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5352 cd     & ' jj=',jj,' kk=',kk
5353 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5354       do iii=1,2
5355         do jjj=1,2
5356           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5357           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5358         enddo
5359       enddo
5360       call transpose2(aa1(1,1),aa1t(1,1))
5361       call transpose2(aa2(1,1),aa2t(1,1))
5362       do kkk=1,5
5363         do lll=1,3
5364           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5365      &      aa1tder(1,1,lll,kkk))
5366           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5367      &      aa2tder(1,1,lll,kkk))
5368         enddo
5369       enddo
5370       if (l.eq.j+1) then
5371 C parallel orientation of the two CA-CA-CA frames.
5372         if (i.gt.1) then
5373           iti=itortyp(itype(i))
5374         else
5375           iti=ntortyp+1
5376         endif
5377         itk1=itortyp(itype(k+1))
5378         itj=itortyp(itype(j))
5379         if (l.lt.nres-1) then
5380           itl1=itortyp(itype(l+1))
5381         else
5382           itl1=ntortyp+1
5383         endif
5384 C A1 kernel(j+1) A2T
5385 cd        do iii=1,2
5386 cd          write (iout,'(3f10.5,5x,3f10.5)')
5387 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5388 cd        enddo
5389         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5390      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5391      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5392 C Following matrices are needed only for 6-th order cumulants
5393         IF (wcorr6.gt.0.0d0) THEN
5394         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5395      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5396      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5397         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5398      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5399      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5400      &   ADtEAderx(1,1,1,1,1,1))
5401         lprn=.false.
5402         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5403      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5404      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5405      &   ADtEA1derx(1,1,1,1,1,1))
5406         ENDIF
5407 C End 6-th order cumulants
5408 cd        lprn=.false.
5409 cd        if (lprn) then
5410 cd        write (2,*) 'In calc_eello6'
5411 cd        do iii=1,2
5412 cd          write (2,*) 'iii=',iii
5413 cd          do kkk=1,5
5414 cd            write (2,*) 'kkk=',kkk
5415 cd            do jjj=1,2
5416 cd              write (2,'(3(2f10.5),5x)')
5417 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5418 cd            enddo
5419 cd          enddo
5420 cd        enddo
5421 cd        endif
5422         call transpose2(EUgder(1,1,k),auxmat(1,1))
5423         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5424         call transpose2(EUg(1,1,k),auxmat(1,1))
5425         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5426         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5427         do iii=1,2
5428           do kkk=1,5
5429             do lll=1,3
5430               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5431      &          EAEAderx(1,1,lll,kkk,iii,1))
5432             enddo
5433           enddo
5434         enddo
5435 C A1T kernel(i+1) A2
5436         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5437      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5438      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5439 C Following matrices are needed only for 6-th order cumulants
5440         IF (wcorr6.gt.0.0d0) THEN
5441         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5442      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5443      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5444         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5445      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
5446      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5447      &   ADtEAderx(1,1,1,1,1,2))
5448         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5449      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5450      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5451      &   ADtEA1derx(1,1,1,1,1,2))
5452         ENDIF
5453 C End 6-th order cumulants
5454         call transpose2(EUgder(1,1,l),auxmat(1,1))
5455         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5456         call transpose2(EUg(1,1,l),auxmat(1,1))
5457         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5458         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5459         do iii=1,2
5460           do kkk=1,5
5461             do lll=1,3
5462               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5463      &          EAEAderx(1,1,lll,kkk,iii,2))
5464             enddo
5465           enddo
5466         enddo
5467 C AEAb1 and AEAb2
5468 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5469 C They are needed only when the fifth- or the sixth-order cumulants are
5470 C indluded.
5471         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5472         call transpose2(AEA(1,1,1),auxmat(1,1))
5473         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5474         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5475         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5476         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5477         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5478         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5479         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5480         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5481         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5482         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5483         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5484         call transpose2(AEA(1,1,2),auxmat(1,1))
5485         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5486         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5487         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5488         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5489         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5490         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5491         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5492         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5493         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5494         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5495         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5496 C Calculate the Cartesian derivatives of the vectors.
5497         do iii=1,2
5498           do kkk=1,5
5499             do lll=1,3
5500               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5501               call matvec2(auxmat(1,1),b1(1,iti),
5502      &          AEAb1derx(1,lll,kkk,iii,1,1))
5503               call matvec2(auxmat(1,1),Ub2(1,i),
5504      &          AEAb2derx(1,lll,kkk,iii,1,1))
5505               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5506      &          AEAb1derx(1,lll,kkk,iii,2,1))
5507               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5508      &          AEAb2derx(1,lll,kkk,iii,2,1))
5509               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5510               call matvec2(auxmat(1,1),b1(1,itj),
5511      &          AEAb1derx(1,lll,kkk,iii,1,2))
5512               call matvec2(auxmat(1,1),Ub2(1,j),
5513      &          AEAb2derx(1,lll,kkk,iii,1,2))
5514               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
5515      &          AEAb1derx(1,lll,kkk,iii,2,2))
5516               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
5517      &          AEAb2derx(1,lll,kkk,iii,2,2))
5518             enddo
5519           enddo
5520         enddo
5521         ENDIF
5522 C End vectors
5523       else
5524 C Antiparallel orientation of the two CA-CA-CA frames.
5525         if (i.gt.1) then
5526           iti=itortyp(itype(i))
5527         else
5528           iti=ntortyp+1
5529         endif
5530         itk1=itortyp(itype(k+1))
5531         itl=itortyp(itype(l))
5532         itj=itortyp(itype(j))
5533         if (j.lt.nres-1) then
5534           itj1=itortyp(itype(j+1))
5535         else
5536           itj1=ntortyp+1
5537         endif
5538 C A2 kernel(j-1)T A1T
5539         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5540      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
5541      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5542 C Following matrices are needed only for 6-th order cumulants
5543         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5544      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5545         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5546      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
5547      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5548         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5549      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
5550      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5551      &   ADtEAderx(1,1,1,1,1,1))
5552         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5553      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
5554      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5555      &   ADtEA1derx(1,1,1,1,1,1))
5556         ENDIF
5557 C End 6-th order cumulants
5558         call transpose2(EUgder(1,1,k),auxmat(1,1))
5559         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5560         call transpose2(EUg(1,1,k),auxmat(1,1))
5561         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5562         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5563         do iii=1,2
5564           do kkk=1,5
5565             do lll=1,3
5566               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5567      &          EAEAderx(1,1,lll,kkk,iii,1))
5568             enddo
5569           enddo
5570         enddo
5571 C A2T kernel(i+1)T A1
5572         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5573      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
5574      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5575 C Following matrices are needed only for 6-th order cumulants
5576         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5577      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5578         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5579      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
5580      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5581         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5582      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
5583      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5584      &   ADtEAderx(1,1,1,1,1,2))
5585         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5586      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
5587      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5588      &   ADtEA1derx(1,1,1,1,1,2))
5589         ENDIF
5590 C End 6-th order cumulants
5591         call transpose2(EUgder(1,1,j),auxmat(1,1))
5592         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
5593         call transpose2(EUg(1,1,j),auxmat(1,1))
5594         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5595         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5596         do iii=1,2
5597           do kkk=1,5
5598             do lll=1,3
5599               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5600      &          EAEAderx(1,1,lll,kkk,iii,2))
5601             enddo
5602           enddo
5603         enddo
5604 C AEAb1 and AEAb2
5605 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5606 C They are needed only when the fifth- or the sixth-order cumulants are
5607 C indluded.
5608         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
5609      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
5610         call transpose2(AEA(1,1,1),auxmat(1,1))
5611         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5612         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5613         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5614         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5615         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5616         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5617         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5618         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5619         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5620         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5621         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5622         call transpose2(AEA(1,1,2),auxmat(1,1))
5623         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
5624         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
5625         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
5626         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5627         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
5628         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
5629         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
5630         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
5631         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
5632         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
5633         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
5634 C Calculate the Cartesian derivatives of the vectors.
5635         do iii=1,2
5636           do kkk=1,5
5637             do lll=1,3
5638               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5639               call matvec2(auxmat(1,1),b1(1,iti),
5640      &          AEAb1derx(1,lll,kkk,iii,1,1))
5641               call matvec2(auxmat(1,1),Ub2(1,i),
5642      &          AEAb2derx(1,lll,kkk,iii,1,1))
5643               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5644      &          AEAb1derx(1,lll,kkk,iii,2,1))
5645               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5646      &          AEAb2derx(1,lll,kkk,iii,2,1))
5647               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5648               call matvec2(auxmat(1,1),b1(1,itl),
5649      &          AEAb1derx(1,lll,kkk,iii,1,2))
5650               call matvec2(auxmat(1,1),Ub2(1,l),
5651      &          AEAb2derx(1,lll,kkk,iii,1,2))
5652               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
5653      &          AEAb1derx(1,lll,kkk,iii,2,2))
5654               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
5655      &          AEAb2derx(1,lll,kkk,iii,2,2))
5656             enddo
5657           enddo
5658         enddo
5659         ENDIF
5660 C End vectors
5661       endif
5662       return
5663       end
5664 C---------------------------------------------------------------------------
5665       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
5666      &  KK,KKderg,AKA,AKAderg,AKAderx)
5667       implicit none
5668       integer nderg
5669       logical transp
5670       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
5671      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
5672      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
5673       integer iii,kkk,lll
5674       integer jjj,mmm
5675       logical lprn
5676       common /kutas/ lprn
5677       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
5678       do iii=1,nderg
5679         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
5680      &    AKAderg(1,1,iii))
5681       enddo
5682 cd      if (lprn) write (2,*) 'In kernel'
5683       do kkk=1,5
5684 cd        if (lprn) write (2,*) 'kkk=',kkk
5685         do lll=1,3
5686           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
5687      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
5688 cd          if (lprn) then
5689 cd            write (2,*) 'lll=',lll
5690 cd            write (2,*) 'iii=1'
5691 cd            do jjj=1,2
5692 cd              write (2,'(3(2f10.5),5x)')
5693 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
5694 cd            enddo
5695 cd          endif
5696           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
5697      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
5698 cd          if (lprn) then
5699 cd            write (2,*) 'lll=',lll
5700 cd            write (2,*) 'iii=2'
5701 cd            do jjj=1,2
5702 cd              write (2,'(3(2f10.5),5x)')
5703 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
5704 cd            enddo
5705 cd          endif
5706         enddo
5707       enddo
5708       return
5709       end
5710 C---------------------------------------------------------------------------
5711       double precision function eello4(i,j,k,l,jj,kk)
5712       implicit real*8 (a-h,o-z)
5713       include 'DIMENSIONS'
5714       include 'DIMENSIONS.ZSCOPT'
5715       include 'COMMON.IOUNITS'
5716       include 'COMMON.CHAIN'
5717       include 'COMMON.DERIV'
5718       include 'COMMON.INTERACT'
5719       include 'COMMON.CONTACTS'
5720       include 'COMMON.TORSION'
5721       include 'COMMON.VAR'
5722       include 'COMMON.GEO'
5723       double precision pizda(2,2),ggg1(3),ggg2(3)
5724 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
5725 cd        eello4=0.0d0
5726 cd        return
5727 cd      endif
5728 cd      print *,'eello4:',i,j,k,l,jj,kk
5729 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
5730 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
5731 cold      eij=facont_hb(jj,i)
5732 cold      ekl=facont_hb(kk,k)
5733 cold      ekont=eij*ekl
5734       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
5735       if (calc_grad) then
5736 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
5737       gcorr_loc(k-1)=gcorr_loc(k-1)
5738      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
5739       if (l.eq.j+1) then
5740         gcorr_loc(l-1)=gcorr_loc(l-1)
5741      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5742       else
5743         gcorr_loc(j-1)=gcorr_loc(j-1)
5744      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5745       endif
5746       do iii=1,2
5747         do kkk=1,5
5748           do lll=1,3
5749             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
5750      &                        -EAEAderx(2,2,lll,kkk,iii,1)
5751 cd            derx(lll,kkk,iii)=0.0d0
5752           enddo
5753         enddo
5754       enddo
5755 cd      gcorr_loc(l-1)=0.0d0
5756 cd      gcorr_loc(j-1)=0.0d0
5757 cd      gcorr_loc(k-1)=0.0d0
5758 cd      eel4=1.0d0
5759 cd      write (iout,*)'Contacts have occurred for peptide groups',
5760 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
5761 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
5762       if (j.lt.nres-1) then
5763         j1=j+1
5764         j2=j-1
5765       else
5766         j1=j-1
5767         j2=j-2
5768       endif
5769       if (l.lt.nres-1) then
5770         l1=l+1
5771         l2=l-1
5772       else
5773         l1=l-1
5774         l2=l-2
5775       endif
5776       do ll=1,3
5777 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
5778         ggg1(ll)=eel4*g_contij(ll,1)
5779         ggg2(ll)=eel4*g_contij(ll,2)
5780         ghalf=0.5d0*ggg1(ll)
5781 cd        ghalf=0.0d0
5782         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
5783         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
5784         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
5785         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
5786 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
5787         ghalf=0.5d0*ggg2(ll)
5788 cd        ghalf=0.0d0
5789         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
5790         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
5791         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
5792         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
5793       enddo
5794 cd      goto 1112
5795       do m=i+1,j-1
5796         do ll=1,3
5797 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
5798           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
5799         enddo
5800       enddo
5801       do m=k+1,l-1
5802         do ll=1,3
5803 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
5804           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
5805         enddo
5806       enddo
5807 1112  continue
5808       do m=i+2,j2
5809         do ll=1,3
5810           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
5811         enddo
5812       enddo
5813       do m=k+2,l2
5814         do ll=1,3
5815           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
5816         enddo
5817       enddo
5818 cd      do iii=1,nres-3
5819 cd        write (2,*) iii,gcorr_loc(iii)
5820 cd      enddo
5821       endif
5822       eello4=ekont*eel4
5823 cd      write (2,*) 'ekont',ekont
5824 cd      write (iout,*) 'eello4',ekont*eel4
5825       return
5826       end
5827 C---------------------------------------------------------------------------
5828       double precision function eello5(i,j,k,l,jj,kk)
5829       implicit real*8 (a-h,o-z)
5830       include 'DIMENSIONS'
5831       include 'DIMENSIONS.ZSCOPT'
5832       include 'COMMON.IOUNITS'
5833       include 'COMMON.CHAIN'
5834       include 'COMMON.DERIV'
5835       include 'COMMON.INTERACT'
5836       include 'COMMON.CONTACTS'
5837       include 'COMMON.TORSION'
5838       include 'COMMON.VAR'
5839       include 'COMMON.GEO'
5840       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
5841       double precision ggg1(3),ggg2(3)
5842 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5843 C                                                                              C
5844 C                            Parallel chains                                   C
5845 C                                                                              C
5846 C          o             o                   o             o                   C
5847 C         /l\           / \             \   / \           / \   /              C
5848 C        /   \         /   \             \ /   \         /   \ /               C
5849 C       j| o |l1       | o |              o| o |         | o |o                C
5850 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
5851 C      \i/   \         /   \ /             /   \         /   \                 C
5852 C       o    k1             o                                                  C
5853 C         (I)          (II)                (III)          (IV)                 C
5854 C                                                                              C
5855 C      eello5_1        eello5_2            eello5_3       eello5_4             C
5856 C                                                                              C
5857 C                            Antiparallel chains                               C
5858 C                                                                              C
5859 C          o             o                   o             o                   C
5860 C         /j\           / \             \   / \           / \   /              C
5861 C        /   \         /   \             \ /   \         /   \ /               C
5862 C      j1| o |l        | o |              o| o |         | o |o                C
5863 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
5864 C      \i/   \         /   \ /             /   \         /   \                 C
5865 C       o     k1            o                                                  C
5866 C         (I)          (II)                (III)          (IV)                 C
5867 C                                                                              C
5868 C      eello5_1        eello5_2            eello5_3       eello5_4             C
5869 C                                                                              C
5870 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
5871 C                                                                              C
5872 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5873 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
5874 cd        eello5=0.0d0
5875 cd        return
5876 cd      endif
5877 cd      write (iout,*)
5878 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
5879 cd     &   ' and',k,l
5880       itk=itortyp(itype(k))
5881       itl=itortyp(itype(l))
5882       itj=itortyp(itype(j))
5883       eello5_1=0.0d0
5884       eello5_2=0.0d0
5885       eello5_3=0.0d0
5886       eello5_4=0.0d0
5887 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
5888 cd     &   eel5_3_num,eel5_4_num)
5889       do iii=1,2
5890         do kkk=1,5
5891           do lll=1,3
5892             derx(lll,kkk,iii)=0.0d0
5893           enddo
5894         enddo
5895       enddo
5896 cd      eij=facont_hb(jj,i)
5897 cd      ekl=facont_hb(kk,k)
5898 cd      ekont=eij*ekl
5899 cd      write (iout,*)'Contacts have occurred for peptide groups',
5900 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
5901 cd      goto 1111
5902 C Contribution from the graph I.
5903 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
5904 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
5905       call transpose2(EUg(1,1,k),auxmat(1,1))
5906       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
5907       vv(1)=pizda(1,1)-pizda(2,2)
5908       vv(2)=pizda(1,2)+pizda(2,1)
5909       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
5910      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
5911       if (calc_grad) then
5912 C Explicit gradient in virtual-dihedral angles.
5913       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
5914      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
5915      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
5916       call transpose2(EUgder(1,1,k),auxmat1(1,1))
5917       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
5918       vv(1)=pizda(1,1)-pizda(2,2)
5919       vv(2)=pizda(1,2)+pizda(2,1)
5920       g_corr5_loc(k-1)=g_corr5_loc(k-1)
5921      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
5922      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5923       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
5924       vv(1)=pizda(1,1)-pizda(2,2)
5925       vv(2)=pizda(1,2)+pizda(2,1)
5926       if (l.eq.j+1) then
5927         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
5928      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
5929      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5930       else
5931         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
5932      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
5933      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5934       endif
5935 C Cartesian gradient
5936       do iii=1,2
5937         do kkk=1,5
5938           do lll=1,3
5939             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
5940      &        pizda(1,1))
5941             vv(1)=pizda(1,1)-pizda(2,2)
5942             vv(2)=pizda(1,2)+pizda(2,1)
5943             derx(lll,kkk,iii)=derx(lll,kkk,iii)
5944      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
5945      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
5946           enddo
5947         enddo
5948       enddo
5949 c      goto 1112
5950       endif
5951 c1111  continue
5952 C Contribution from graph II
5953       call transpose2(EE(1,1,itk),auxmat(1,1))
5954       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
5955       vv(1)=pizda(1,1)+pizda(2,2)
5956       vv(2)=pizda(2,1)-pizda(1,2)
5957       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
5958      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
5959       if (calc_grad) then
5960 C Explicit gradient in virtual-dihedral angles.
5961       g_corr5_loc(k-1)=g_corr5_loc(k-1)
5962      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
5963       call matmat2(auxmat(1,1),AEAderg(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       if (l.eq.j+1) then
5967         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5968      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
5969      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
5970       else
5971         g_corr5_loc(j-1)=g_corr5_loc(j-1)
5972      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
5973      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
5974       endif
5975 C Cartesian gradient
5976       do iii=1,2
5977         do kkk=1,5
5978           do lll=1,3
5979             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5980      &        pizda(1,1))
5981             vv(1)=pizda(1,1)+pizda(2,2)
5982             vv(2)=pizda(2,1)-pizda(1,2)
5983             derx(lll,kkk,iii)=derx(lll,kkk,iii)
5984      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
5985      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
5986           enddo
5987         enddo
5988       enddo
5989 cd      goto 1112
5990       endif
5991 cd1111  continue
5992       if (l.eq.j+1) then
5993 cd        goto 1110
5994 C Parallel orientation
5995 C Contribution from graph III
5996         call transpose2(EUg(1,1,l),auxmat(1,1))
5997         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
5998         vv(1)=pizda(1,1)-pizda(2,2)
5999         vv(2)=pizda(1,2)+pizda(2,1)
6000         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6001      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6002         if (calc_grad) then
6003 C Explicit gradient in virtual-dihedral angles.
6004         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6005      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6006      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6007         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6008         vv(1)=pizda(1,1)-pizda(2,2)
6009         vv(2)=pizda(1,2)+pizda(2,1)
6010         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6011      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6012      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6013         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6014         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6015         vv(1)=pizda(1,1)-pizda(2,2)
6016         vv(2)=pizda(1,2)+pizda(2,1)
6017         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6018      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6019      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6020 C Cartesian gradient
6021         do iii=1,2
6022           do kkk=1,5
6023             do lll=1,3
6024               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6025      &          pizda(1,1))
6026               vv(1)=pizda(1,1)-pizda(2,2)
6027               vv(2)=pizda(1,2)+pizda(2,1)
6028               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6029      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6030      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6031             enddo
6032           enddo
6033         enddo
6034 cd        goto 1112
6035         endif
6036 C Contribution from graph IV
6037 cd1110    continue
6038         call transpose2(EE(1,1,itl),auxmat(1,1))
6039         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6040         vv(1)=pizda(1,1)+pizda(2,2)
6041         vv(2)=pizda(2,1)-pizda(1,2)
6042         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6043      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6044         if (calc_grad) then
6045 C Explicit gradient in virtual-dihedral angles.
6046         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6047      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6048         call matmat2(auxmat(1,1),AEAderg(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         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6052      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6053      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6054 C Cartesian gradient
6055         do iii=1,2
6056           do kkk=1,5
6057             do lll=1,3
6058               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6059      &          pizda(1,1))
6060               vv(1)=pizda(1,1)+pizda(2,2)
6061               vv(2)=pizda(2,1)-pizda(1,2)
6062               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6063      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6064      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6065             enddo
6066           enddo
6067         enddo
6068         endif
6069       else
6070 C Antiparallel orientation
6071 C Contribution from graph III
6072 c        goto 1110
6073         call transpose2(EUg(1,1,j),auxmat(1,1))
6074         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6075         vv(1)=pizda(1,1)-pizda(2,2)
6076         vv(2)=pizda(1,2)+pizda(2,1)
6077         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6078      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6079         if (calc_grad) then
6080 C Explicit gradient in virtual-dihedral angles.
6081         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6082      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6083      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6084         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6085         vv(1)=pizda(1,1)-pizda(2,2)
6086         vv(2)=pizda(1,2)+pizda(2,1)
6087         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6088      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6089      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6090         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6091         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6092         vv(1)=pizda(1,1)-pizda(2,2)
6093         vv(2)=pizda(1,2)+pizda(2,1)
6094         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6095      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6096      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6097 C Cartesian gradient
6098         do iii=1,2
6099           do kkk=1,5
6100             do lll=1,3
6101               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6102      &          pizda(1,1))
6103               vv(1)=pizda(1,1)-pizda(2,2)
6104               vv(2)=pizda(1,2)+pizda(2,1)
6105               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6106      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6107      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6108             enddo
6109           enddo
6110         enddo
6111 cd        goto 1112
6112         endif
6113 C Contribution from graph IV
6114 1110    continue
6115         call transpose2(EE(1,1,itj),auxmat(1,1))
6116         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6117         vv(1)=pizda(1,1)+pizda(2,2)
6118         vv(2)=pizda(2,1)-pizda(1,2)
6119         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6120      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6121         if (calc_grad) then
6122 C Explicit gradient in virtual-dihedral angles.
6123         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6124      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6125         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6126         vv(1)=pizda(1,1)+pizda(2,2)
6127         vv(2)=pizda(2,1)-pizda(1,2)
6128         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6129      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6130      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6131 C Cartesian gradient
6132         do iii=1,2
6133           do kkk=1,5
6134             do lll=1,3
6135               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6136      &          pizda(1,1))
6137               vv(1)=pizda(1,1)+pizda(2,2)
6138               vv(2)=pizda(2,1)-pizda(1,2)
6139               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6140      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6141      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6142             enddo
6143           enddo
6144         enddo
6145       endif
6146       endif
6147 1112  continue
6148       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6149 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6150 cd        write (2,*) 'ijkl',i,j,k,l
6151 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6152 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6153 cd      endif
6154 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6155 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6156 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6157 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6158       if (calc_grad) then
6159       if (j.lt.nres-1) then
6160         j1=j+1
6161         j2=j-1
6162       else
6163         j1=j-1
6164         j2=j-2
6165       endif
6166       if (l.lt.nres-1) then
6167         l1=l+1
6168         l2=l-1
6169       else
6170         l1=l-1
6171         l2=l-2
6172       endif
6173 cd      eij=1.0d0
6174 cd      ekl=1.0d0
6175 cd      ekont=1.0d0
6176 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6177       do ll=1,3
6178         ggg1(ll)=eel5*g_contij(ll,1)
6179         ggg2(ll)=eel5*g_contij(ll,2)
6180 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6181         ghalf=0.5d0*ggg1(ll)
6182 cd        ghalf=0.0d0
6183         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6184         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6185         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6186         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6187 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6188         ghalf=0.5d0*ggg2(ll)
6189 cd        ghalf=0.0d0
6190         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6191         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6192         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6193         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6194       enddo
6195 cd      goto 1112
6196       do m=i+1,j-1
6197         do ll=1,3
6198 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6199           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6200         enddo
6201       enddo
6202       do m=k+1,l-1
6203         do ll=1,3
6204 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6205           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6206         enddo
6207       enddo
6208 c1112  continue
6209       do m=i+2,j2
6210         do ll=1,3
6211           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6212         enddo
6213       enddo
6214       do m=k+2,l2
6215         do ll=1,3
6216           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6217         enddo
6218       enddo
6219 cd      do iii=1,nres-3
6220 cd        write (2,*) iii,g_corr5_loc(iii)
6221 cd      enddo
6222       endif
6223       eello5=ekont*eel5
6224 cd      write (2,*) 'ekont',ekont
6225 cd      write (iout,*) 'eello5',ekont*eel5
6226       return
6227       end
6228 c--------------------------------------------------------------------------
6229       double precision function eello6(i,j,k,l,jj,kk)
6230       implicit real*8 (a-h,o-z)
6231       include 'DIMENSIONS'
6232       include 'DIMENSIONS.ZSCOPT'
6233       include 'COMMON.IOUNITS'
6234       include 'COMMON.CHAIN'
6235       include 'COMMON.DERIV'
6236       include 'COMMON.INTERACT'
6237       include 'COMMON.CONTACTS'
6238       include 'COMMON.TORSION'
6239       include 'COMMON.VAR'
6240       include 'COMMON.GEO'
6241       include 'COMMON.FFIELD'
6242       double precision ggg1(3),ggg2(3)
6243 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6244 cd        eello6=0.0d0
6245 cd        return
6246 cd      endif
6247 cd      write (iout,*)
6248 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6249 cd     &   ' and',k,l
6250       eello6_1=0.0d0
6251       eello6_2=0.0d0
6252       eello6_3=0.0d0
6253       eello6_4=0.0d0
6254       eello6_5=0.0d0
6255       eello6_6=0.0d0
6256 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6257 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6258       do iii=1,2
6259         do kkk=1,5
6260           do lll=1,3
6261             derx(lll,kkk,iii)=0.0d0
6262           enddo
6263         enddo
6264       enddo
6265 cd      eij=facont_hb(jj,i)
6266 cd      ekl=facont_hb(kk,k)
6267 cd      ekont=eij*ekl
6268 cd      eij=1.0d0
6269 cd      ekl=1.0d0
6270 cd      ekont=1.0d0
6271       if (l.eq.j+1) then
6272         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6273         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6274         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6275         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6276         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6277         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6278       else
6279         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6280         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6281         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6282         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6283         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6284           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6285         else
6286           eello6_5=0.0d0
6287         endif
6288         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6289       endif
6290 C If turn contributions are considered, they will be handled separately.
6291       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6292 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6293 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6294 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6295 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6296 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6297 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6298 cd      goto 1112
6299       if (calc_grad) then
6300       if (j.lt.nres-1) then
6301         j1=j+1
6302         j2=j-1
6303       else
6304         j1=j-1
6305         j2=j-2
6306       endif
6307       if (l.lt.nres-1) then
6308         l1=l+1
6309         l2=l-1
6310       else
6311         l1=l-1
6312         l2=l-2
6313       endif
6314       do ll=1,3
6315         ggg1(ll)=eel6*g_contij(ll,1)
6316         ggg2(ll)=eel6*g_contij(ll,2)
6317 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6318         ghalf=0.5d0*ggg1(ll)
6319 cd        ghalf=0.0d0
6320         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6321         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6322         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6323         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6324         ghalf=0.5d0*ggg2(ll)
6325 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6326 cd        ghalf=0.0d0
6327         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6328         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6329         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6330         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6331       enddo
6332 cd      goto 1112
6333       do m=i+1,j-1
6334         do ll=1,3
6335 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6336           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6337         enddo
6338       enddo
6339       do m=k+1,l-1
6340         do ll=1,3
6341 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6342           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6343         enddo
6344       enddo
6345 1112  continue
6346       do m=i+2,j2
6347         do ll=1,3
6348           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6349         enddo
6350       enddo
6351       do m=k+2,l2
6352         do ll=1,3
6353           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6354         enddo
6355       enddo
6356 cd      do iii=1,nres-3
6357 cd        write (2,*) iii,g_corr6_loc(iii)
6358 cd      enddo
6359       endif
6360       eello6=ekont*eel6
6361 cd      write (2,*) 'ekont',ekont
6362 cd      write (iout,*) 'eello6',ekont*eel6
6363       return
6364       end
6365 c--------------------------------------------------------------------------
6366       double precision function eello6_graph1(i,j,k,l,imat,swap)
6367       implicit real*8 (a-h,o-z)
6368       include 'DIMENSIONS'
6369       include 'DIMENSIONS.ZSCOPT'
6370       include 'COMMON.IOUNITS'
6371       include 'COMMON.CHAIN'
6372       include 'COMMON.DERIV'
6373       include 'COMMON.INTERACT'
6374       include 'COMMON.CONTACTS'
6375       include 'COMMON.TORSION'
6376       include 'COMMON.VAR'
6377       include 'COMMON.GEO'
6378       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6379       logical swap
6380       logical lprn
6381       common /kutas/ lprn
6382 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6383 C                                                                              C
6384 C      Parallel       Antiparallel                                             C
6385 C                                                                              C
6386 C          o             o                                                     C
6387 C         /l\           /j\                                                    C
6388 C        /   \         /   \                                                   C
6389 C       /| o |         | o |\                                                  C
6390 C     \ j|/k\|  /   \  |/k\|l /                                                C
6391 C      \ /   \ /     \ /   \ /                                                 C
6392 C       o     o       o     o                                                  C
6393 C       i             i                                                        C
6394 C                                                                              C
6395 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6396       itk=itortyp(itype(k))
6397       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6398       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6399       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6400       call transpose2(EUgC(1,1,k),auxmat(1,1))
6401       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6402       vv1(1)=pizda1(1,1)-pizda1(2,2)
6403       vv1(2)=pizda1(1,2)+pizda1(2,1)
6404       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6405       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6406       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6407       s5=scalar2(vv(1),Dtobr2(1,i))
6408 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6409       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6410       if (.not. calc_grad) return
6411       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6412      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6413      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6414      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6415      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6416      & +scalar2(vv(1),Dtobr2der(1,i)))
6417       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6418       vv1(1)=pizda1(1,1)-pizda1(2,2)
6419       vv1(2)=pizda1(1,2)+pizda1(2,1)
6420       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6421       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6422       if (l.eq.j+1) then
6423         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6424      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6425      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6426      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6427      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6428       else
6429         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6430      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6431      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6432      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6433      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6434       endif
6435       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6436       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6437       vv1(1)=pizda1(1,1)-pizda1(2,2)
6438       vv1(2)=pizda1(1,2)+pizda1(2,1)
6439       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6440      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6441      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6442      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6443       do iii=1,2
6444         if (swap) then
6445           ind=3-iii
6446         else
6447           ind=iii
6448         endif
6449         do kkk=1,5
6450           do lll=1,3
6451             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6452             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6453             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6454             call transpose2(EUgC(1,1,k),auxmat(1,1))
6455             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6456      &        pizda1(1,1))
6457             vv1(1)=pizda1(1,1)-pizda1(2,2)
6458             vv1(2)=pizda1(1,2)+pizda1(2,1)
6459             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6460             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6461      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6462             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6463      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6464             s5=scalar2(vv(1),Dtobr2(1,i))
6465             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6466           enddo
6467         enddo
6468       enddo
6469       return
6470       end
6471 c----------------------------------------------------------------------------
6472       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6473       implicit real*8 (a-h,o-z)
6474       include 'DIMENSIONS'
6475       include 'DIMENSIONS.ZSCOPT'
6476       include 'COMMON.IOUNITS'
6477       include 'COMMON.CHAIN'
6478       include 'COMMON.DERIV'
6479       include 'COMMON.INTERACT'
6480       include 'COMMON.CONTACTS'
6481       include 'COMMON.TORSION'
6482       include 'COMMON.VAR'
6483       include 'COMMON.GEO'
6484       logical swap
6485       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6486      & auxvec1(2),auxvec2(2),auxmat1(2,2)
6487       logical lprn
6488       common /kutas/ lprn
6489 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6490 C                                                                              C
6491 C      Parallel       Antiparallel                                             C
6492 C                                                                              C
6493 C          o             o                                                     C
6494 C     \   /l\           /j\   /                                                C
6495 C      \ /   \         /   \ /                                                 C
6496 C       o| o |         | o |o                                                  C
6497 C     \ j|/k\|      \  |/k\|l                                                  C
6498 C      \ /   \       \ /   \                                                   C
6499 C       o             o                                                        C
6500 C       i             i                                                        C
6501 C                                                                              C
6502 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6503 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6504 C AL 7/4/01 s1 would occur in the sixth-order moment,
6505 C           but not in a cluster cumulant
6506 #ifdef MOMENT
6507       s1=dip(1,jj,i)*dip(1,kk,k)
6508 #endif
6509       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
6510       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6511       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
6512       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
6513       call transpose2(EUg(1,1,k),auxmat(1,1))
6514       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
6515       vv(1)=pizda(1,1)-pizda(2,2)
6516       vv(2)=pizda(1,2)+pizda(2,1)
6517       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6518 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6519 #ifdef MOMENT
6520       eello6_graph2=-(s1+s2+s3+s4)
6521 #else
6522       eello6_graph2=-(s2+s3+s4)
6523 #endif
6524 c      eello6_graph2=-s3
6525       if (.not. calc_grad) return
6526 C Derivatives in gamma(i-1)
6527       if (i.gt.1) then
6528 #ifdef MOMENT
6529         s1=dipderg(1,jj,i)*dip(1,kk,k)
6530 #endif
6531         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6532         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
6533         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6534         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6535 #ifdef MOMENT
6536         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6537 #else
6538         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6539 #endif
6540 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
6541       endif
6542 C Derivatives in gamma(k-1)
6543 #ifdef MOMENT
6544       s1=dip(1,jj,i)*dipderg(1,kk,k)
6545 #endif
6546       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
6547       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6548       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
6549       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6550       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6551       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
6552       vv(1)=pizda(1,1)-pizda(2,2)
6553       vv(2)=pizda(1,2)+pizda(2,1)
6554       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6555 #ifdef MOMENT
6556       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6557 #else
6558       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6559 #endif
6560 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
6561 C Derivatives in gamma(j-1) or gamma(l-1)
6562       if (j.gt.1) then
6563 #ifdef MOMENT
6564         s1=dipderg(3,jj,i)*dip(1,kk,k)
6565 #endif
6566         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
6567         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6568         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
6569         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
6570         vv(1)=pizda(1,1)-pizda(2,2)
6571         vv(2)=pizda(1,2)+pizda(2,1)
6572         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6573 #ifdef MOMENT
6574         if (swap) then
6575           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6576         else
6577           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6578         endif
6579 #endif
6580         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
6581 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
6582       endif
6583 C Derivatives in gamma(l-1) or gamma(j-1)
6584       if (l.gt.1) then
6585 #ifdef MOMENT
6586         s1=dip(1,jj,i)*dipderg(3,kk,k)
6587 #endif
6588         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
6589         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6590         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
6591         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6592         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
6593         vv(1)=pizda(1,1)-pizda(2,2)
6594         vv(2)=pizda(1,2)+pizda(2,1)
6595         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6596 #ifdef MOMENT
6597         if (swap) then
6598           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6599         else
6600           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6601         endif
6602 #endif
6603         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
6604 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
6605       endif
6606 C Cartesian derivatives.
6607       if (lprn) then
6608         write (2,*) 'In eello6_graph2'
6609         do iii=1,2
6610           write (2,*) 'iii=',iii
6611           do kkk=1,5
6612             write (2,*) 'kkk=',kkk
6613             do jjj=1,2
6614               write (2,'(3(2f10.5),5x)')
6615      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6616             enddo
6617           enddo
6618         enddo
6619       endif
6620       do iii=1,2
6621         do kkk=1,5
6622           do lll=1,3
6623 #ifdef MOMENT
6624             if (iii.eq.1) then
6625               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
6626             else
6627               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
6628             endif
6629 #endif
6630             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
6631      &        auxvec(1))
6632             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6633             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
6634      &        auxvec(1))
6635             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
6636             call transpose2(EUg(1,1,k),auxmat(1,1))
6637             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
6638      &        pizda(1,1))
6639             vv(1)=pizda(1,1)-pizda(2,2)
6640             vv(2)=pizda(1,2)+pizda(2,1)
6641             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6642 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
6643 #ifdef MOMENT
6644             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6645 #else
6646             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6647 #endif
6648             if (swap) then
6649               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6650             else
6651               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6652             endif
6653           enddo
6654         enddo
6655       enddo
6656       return
6657       end
6658 c----------------------------------------------------------------------------
6659       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
6660       implicit real*8 (a-h,o-z)
6661       include 'DIMENSIONS'
6662       include 'DIMENSIONS.ZSCOPT'
6663       include 'COMMON.IOUNITS'
6664       include 'COMMON.CHAIN'
6665       include 'COMMON.DERIV'
6666       include 'COMMON.INTERACT'
6667       include 'COMMON.CONTACTS'
6668       include 'COMMON.TORSION'
6669       include 'COMMON.VAR'
6670       include 'COMMON.GEO'
6671       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
6672       logical swap
6673 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6674 C                                                                              C
6675 C      Parallel       Antiparallel                                             C
6676 C                                                                              C
6677 C          o             o                                                     C
6678 C         /l\   /   \   /j\                                                    C
6679 C        /   \ /     \ /   \                                                   C
6680 C       /| o |o       o| o |\                                                  C
6681 C       j|/k\|  /      |/k\|l /                                                C
6682 C        /   \ /       /   \ /                                                 C
6683 C       /     o       /     o                                                  C
6684 C       i             i                                                        C
6685 C                                                                              C
6686 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6687 C
6688 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6689 C           energy moment and not to the cluster cumulant.
6690       iti=itortyp(itype(i))
6691       if (j.lt.nres-1) then
6692         itj1=itortyp(itype(j+1))
6693       else
6694         itj1=ntortyp+1
6695       endif
6696       itk=itortyp(itype(k))
6697       itk1=itortyp(itype(k+1))
6698       if (l.lt.nres-1) then
6699         itl1=itortyp(itype(l+1))
6700       else
6701         itl1=ntortyp+1
6702       endif
6703 #ifdef MOMENT
6704       s1=dip(4,jj,i)*dip(4,kk,k)
6705 #endif
6706       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
6707       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6708       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
6709       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6710       call transpose2(EE(1,1,itk),auxmat(1,1))
6711       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
6712       vv(1)=pizda(1,1)+pizda(2,2)
6713       vv(2)=pizda(2,1)-pizda(1,2)
6714       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6715 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6716 #ifdef MOMENT
6717       eello6_graph3=-(s1+s2+s3+s4)
6718 #else
6719       eello6_graph3=-(s2+s3+s4)
6720 #endif
6721 c      eello6_graph3=-s4
6722       if (.not. calc_grad) return
6723 C Derivatives in gamma(k-1)
6724       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
6725       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6726       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
6727       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
6728 C Derivatives in gamma(l-1)
6729       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
6730       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6731       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
6732       vv(1)=pizda(1,1)+pizda(2,2)
6733       vv(2)=pizda(2,1)-pizda(1,2)
6734       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6735       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6736 C Cartesian derivatives.
6737       do iii=1,2
6738         do kkk=1,5
6739           do lll=1,3
6740 #ifdef MOMENT
6741             if (iii.eq.1) then
6742               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
6743             else
6744               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
6745             endif
6746 #endif
6747             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6748      &        auxvec(1))
6749             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6750             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6751      &        auxvec(1))
6752             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6753             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
6754      &        pizda(1,1))
6755             vv(1)=pizda(1,1)+pizda(2,2)
6756             vv(2)=pizda(2,1)-pizda(1,2)
6757             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6758 #ifdef MOMENT
6759             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6760 #else
6761             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6762 #endif
6763             if (swap) then
6764               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6765             else
6766               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6767             endif
6768 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
6769           enddo
6770         enddo
6771       enddo
6772       return
6773       end
6774 c----------------------------------------------------------------------------
6775       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
6776       implicit real*8 (a-h,o-z)
6777       include 'DIMENSIONS'
6778       include 'DIMENSIONS.ZSCOPT'
6779       include 'COMMON.IOUNITS'
6780       include 'COMMON.CHAIN'
6781       include 'COMMON.DERIV'
6782       include 'COMMON.INTERACT'
6783       include 'COMMON.CONTACTS'
6784       include 'COMMON.TORSION'
6785       include 'COMMON.VAR'
6786       include 'COMMON.GEO'
6787       include 'COMMON.FFIELD'
6788       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6789      & auxvec1(2),auxmat1(2,2)
6790       logical swap
6791 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6792 C                                                                              C
6793 C      Parallel       Antiparallel                                             C
6794 C                                                                              C
6795 C          o             o                                                     C
6796 C         /l\   /   \   /j\                                                    C
6797 C        /   \ /     \ /   \                                                   C
6798 C       /| o |o       o| o |\                                                  C
6799 C     \ j|/k\|      \  |/k\|l                                                  C
6800 C      \ /   \       \ /   \                                                   C
6801 C       o     \       o     \                                                  C
6802 C       i             i                                                        C
6803 C                                                                              C
6804 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6805 C
6806 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6807 C           energy moment and not to the cluster cumulant.
6808 cd      write (2,*) 'eello_graph4: wturn6',wturn6
6809       iti=itortyp(itype(i))
6810       itj=itortyp(itype(j))
6811       if (j.lt.nres-1) then
6812         itj1=itortyp(itype(j+1))
6813       else
6814         itj1=ntortyp+1
6815       endif
6816       itk=itortyp(itype(k))
6817       if (k.lt.nres-1) then
6818         itk1=itortyp(itype(k+1))
6819       else
6820         itk1=ntortyp+1
6821       endif
6822       itl=itortyp(itype(l))
6823       if (l.lt.nres-1) then
6824         itl1=itortyp(itype(l+1))
6825       else
6826         itl1=ntortyp+1
6827       endif
6828 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
6829 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
6830 cd     & ' itl',itl,' itl1',itl1
6831 #ifdef MOMENT
6832       if (imat.eq.1) then
6833         s1=dip(3,jj,i)*dip(3,kk,k)
6834       else
6835         s1=dip(2,jj,j)*dip(2,kk,l)
6836       endif
6837 #endif
6838       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
6839       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6840       if (j.eq.l+1) then
6841         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
6842         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6843       else
6844         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
6845         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6846       endif
6847       call transpose2(EUg(1,1,k),auxmat(1,1))
6848       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
6849       vv(1)=pizda(1,1)-pizda(2,2)
6850       vv(2)=pizda(2,1)+pizda(1,2)
6851       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6852 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6853 #ifdef MOMENT
6854       eello6_graph4=-(s1+s2+s3+s4)
6855 #else
6856       eello6_graph4=-(s2+s3+s4)
6857 #endif
6858       if (.not. calc_grad) return
6859 C Derivatives in gamma(i-1)
6860       if (i.gt.1) then
6861 #ifdef MOMENT
6862         if (imat.eq.1) then
6863           s1=dipderg(2,jj,i)*dip(3,kk,k)
6864         else
6865           s1=dipderg(4,jj,j)*dip(2,kk,l)
6866         endif
6867 #endif
6868         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6869         if (j.eq.l+1) then
6870           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
6871           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6872         else
6873           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
6874           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6875         endif
6876         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6877         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6878 cd          write (2,*) 'turn6 derivatives'
6879 #ifdef MOMENT
6880           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
6881 #else
6882           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
6883 #endif
6884         else
6885 #ifdef MOMENT
6886           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6887 #else
6888           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6889 #endif
6890         endif
6891       endif
6892 C Derivatives in gamma(k-1)
6893 #ifdef MOMENT
6894       if (imat.eq.1) then
6895         s1=dip(3,jj,i)*dipderg(2,kk,k)
6896       else
6897         s1=dip(2,jj,j)*dipderg(4,kk,l)
6898       endif
6899 #endif
6900       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
6901       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
6902       if (j.eq.l+1) then
6903         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
6904         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6905       else
6906         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
6907         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6908       endif
6909       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6910       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
6911       vv(1)=pizda(1,1)-pizda(2,2)
6912       vv(2)=pizda(2,1)+pizda(1,2)
6913       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6914       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6915 #ifdef MOMENT
6916         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
6917 #else
6918         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
6919 #endif
6920       else
6921 #ifdef MOMENT
6922         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6923 #else
6924         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6925 #endif
6926       endif
6927 C Derivatives in gamma(j-1) or gamma(l-1)
6928       if (l.eq.j+1 .and. l.gt.1) then
6929         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
6930         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6931         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
6932         vv(1)=pizda(1,1)-pizda(2,2)
6933         vv(2)=pizda(2,1)+pizda(1,2)
6934         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6935         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6936       else if (j.gt.1) then
6937         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
6938         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6939         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
6940         vv(1)=pizda(1,1)-pizda(2,2)
6941         vv(2)=pizda(2,1)+pizda(1,2)
6942         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6943         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6944           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
6945         else
6946           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
6947         endif
6948       endif
6949 C Cartesian derivatives.
6950       do iii=1,2
6951         do kkk=1,5
6952           do lll=1,3
6953 #ifdef MOMENT
6954             if (iii.eq.1) then
6955               if (imat.eq.1) then
6956                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
6957               else
6958                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
6959               endif
6960             else
6961               if (imat.eq.1) then
6962                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
6963               else
6964                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
6965               endif
6966             endif
6967 #endif
6968             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
6969      &        auxvec(1))
6970             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6971             if (j.eq.l+1) then
6972               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
6973      &          b1(1,itj1),auxvec(1))
6974               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
6975             else
6976               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
6977      &          b1(1,itl1),auxvec(1))
6978               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
6979             endif
6980             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6981      &        pizda(1,1))
6982             vv(1)=pizda(1,1)-pizda(2,2)
6983             vv(2)=pizda(2,1)+pizda(1,2)
6984             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6985             if (swap) then
6986               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6987 #ifdef MOMENT
6988                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
6989      &             -(s1+s2+s4)
6990 #else
6991                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
6992      &             -(s2+s4)
6993 #endif
6994                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
6995               else
6996 #ifdef MOMENT
6997                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
6998 #else
6999                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7000 #endif
7001                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7002               endif
7003             else
7004 #ifdef MOMENT
7005               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7006 #else
7007               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7008 #endif
7009               if (l.eq.j+1) then
7010                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7011               else
7012                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7013               endif
7014             endif
7015           enddo
7016         enddo
7017       enddo
7018       return
7019       end
7020 c----------------------------------------------------------------------------
7021       double precision function eello_turn6(i,jj,kk)
7022       implicit real*8 (a-h,o-z)
7023       include 'DIMENSIONS'
7024       include 'DIMENSIONS.ZSCOPT'
7025       include 'COMMON.IOUNITS'
7026       include 'COMMON.CHAIN'
7027       include 'COMMON.DERIV'
7028       include 'COMMON.INTERACT'
7029       include 'COMMON.CONTACTS'
7030       include 'COMMON.TORSION'
7031       include 'COMMON.VAR'
7032       include 'COMMON.GEO'
7033       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7034      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7035      &  ggg1(3),ggg2(3)
7036       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7037      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7038 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7039 C           the respective energy moment and not to the cluster cumulant.
7040       eello_turn6=0.0d0
7041       j=i+4
7042       k=i+1
7043       l=i+3
7044       iti=itortyp(itype(i))
7045       itk=itortyp(itype(k))
7046       itk1=itortyp(itype(k+1))
7047       itl=itortyp(itype(l))
7048       itj=itortyp(itype(j))
7049 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7050 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7051 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7052 cd        eello6=0.0d0
7053 cd        return
7054 cd      endif
7055 cd      write (iout,*)
7056 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7057 cd     &   ' and',k,l
7058 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7059       do iii=1,2
7060         do kkk=1,5
7061           do lll=1,3
7062             derx_turn(lll,kkk,iii)=0.0d0
7063           enddo
7064         enddo
7065       enddo
7066 cd      eij=1.0d0
7067 cd      ekl=1.0d0
7068 cd      ekont=1.0d0
7069       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7070 cd      eello6_5=0.0d0
7071 cd      write (2,*) 'eello6_5',eello6_5
7072 #ifdef MOMENT
7073       call transpose2(AEA(1,1,1),auxmat(1,1))
7074       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7075       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7076       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7077 #else
7078       s1 = 0.0d0
7079 #endif
7080       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7081       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7082       s2 = scalar2(b1(1,itk),vtemp1(1))
7083 #ifdef MOMENT
7084       call transpose2(AEA(1,1,2),atemp(1,1))
7085       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7086       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7087       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7088 #else
7089       s8=0.0d0
7090 #endif
7091       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7092       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7093       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7094 #ifdef MOMENT
7095       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7096       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7097       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7098       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7099       ss13 = scalar2(b1(1,itk),vtemp4(1))
7100       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7101 #else
7102       s13=0.0d0
7103 #endif
7104 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7105 c      s1=0.0d0
7106 c      s2=0.0d0
7107 c      s8=0.0d0
7108 c      s12=0.0d0
7109 c      s13=0.0d0
7110       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7111       if (calc_grad) then
7112 C Derivatives in gamma(i+2)
7113 #ifdef MOMENT
7114       call transpose2(AEA(1,1,1),auxmatd(1,1))
7115       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7116       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7117       call transpose2(AEAderg(1,1,2),atempd(1,1))
7118       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7119       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7120 #else
7121       s8d=0.0d0
7122 #endif
7123       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7124       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7125       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7126 c      s1d=0.0d0
7127 c      s2d=0.0d0
7128 c      s8d=0.0d0
7129 c      s12d=0.0d0
7130 c      s13d=0.0d0
7131       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7132 C Derivatives in gamma(i+3)
7133 #ifdef MOMENT
7134       call transpose2(AEA(1,1,1),auxmatd(1,1))
7135       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7136       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7137       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7138 #else
7139       s1d=0.0d0
7140 #endif
7141       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7142       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7143       s2d = scalar2(b1(1,itk),vtemp1d(1))
7144 #ifdef MOMENT
7145       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7146       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7147 #endif
7148       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7149 #ifdef MOMENT
7150       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7151       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7152       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7153 #else
7154       s13d=0.0d0
7155 #endif
7156 c      s1d=0.0d0
7157 c      s2d=0.0d0
7158 c      s8d=0.0d0
7159 c      s12d=0.0d0
7160 c      s13d=0.0d0
7161 #ifdef MOMENT
7162       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7163      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7164 #else
7165       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7166      &               -0.5d0*ekont*(s2d+s12d)
7167 #endif
7168 C Derivatives in gamma(i+4)
7169       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7170       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7171       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7172 #ifdef MOMENT
7173       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7174       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7175       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7176 #else
7177       s13d = 0.0d0
7178 #endif
7179 c      s1d=0.0d0
7180 c      s2d=0.0d0
7181 c      s8d=0.0d0
7182 C      s12d=0.0d0
7183 c      s13d=0.0d0
7184 #ifdef MOMENT
7185       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7186 #else
7187       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7188 #endif
7189 C Derivatives in gamma(i+5)
7190 #ifdef MOMENT
7191       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7192       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7193       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7194 #else
7195       s1d = 0.0d0
7196 #endif
7197       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7198       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7199       s2d = scalar2(b1(1,itk),vtemp1d(1))
7200 #ifdef MOMENT
7201       call transpose2(AEA(1,1,2),atempd(1,1))
7202       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7203       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7204 #else
7205       s8d = 0.0d0
7206 #endif
7207       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7208       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7209 #ifdef MOMENT
7210       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7211       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7212       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7213 #else
7214       s13d = 0.0d0
7215 #endif
7216 c      s1d=0.0d0
7217 c      s2d=0.0d0
7218 c      s8d=0.0d0
7219 c      s12d=0.0d0
7220 c      s13d=0.0d0
7221 #ifdef MOMENT
7222       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7223      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7224 #else
7225       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7226      &               -0.5d0*ekont*(s2d+s12d)
7227 #endif
7228 C Cartesian derivatives
7229       do iii=1,2
7230         do kkk=1,5
7231           do lll=1,3
7232 #ifdef MOMENT
7233             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7234             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7235             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7236 #else
7237             s1d = 0.0d0
7238 #endif
7239             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7240             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7241      &          vtemp1d(1))
7242             s2d = scalar2(b1(1,itk),vtemp1d(1))
7243 #ifdef MOMENT
7244             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7245             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7246             s8d = -(atempd(1,1)+atempd(2,2))*
7247      &           scalar2(cc(1,1,itl),vtemp2(1))
7248 #else
7249             s8d = 0.0d0
7250 #endif
7251             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7252      &           auxmatd(1,1))
7253             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7254             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7255 c      s1d=0.0d0
7256 c      s2d=0.0d0
7257 c      s8d=0.0d0
7258 c      s12d=0.0d0
7259 c      s13d=0.0d0
7260 #ifdef MOMENT
7261             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7262      &        - 0.5d0*(s1d+s2d)
7263 #else
7264             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7265      &        - 0.5d0*s2d
7266 #endif
7267 #ifdef MOMENT
7268             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7269      &        - 0.5d0*(s8d+s12d)
7270 #else
7271             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7272      &        - 0.5d0*s12d
7273 #endif
7274           enddo
7275         enddo
7276       enddo
7277 #ifdef MOMENT
7278       do kkk=1,5
7279         do lll=1,3
7280           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7281      &      achuj_tempd(1,1))
7282           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7283           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7284           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7285           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7286           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7287      &      vtemp4d(1))
7288           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7289           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7290           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7291         enddo
7292       enddo
7293 #endif
7294 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7295 cd     &  16*eel_turn6_num
7296 cd      goto 1112
7297       if (j.lt.nres-1) then
7298         j1=j+1
7299         j2=j-1
7300       else
7301         j1=j-1
7302         j2=j-2
7303       endif
7304       if (l.lt.nres-1) then
7305         l1=l+1
7306         l2=l-1
7307       else
7308         l1=l-1
7309         l2=l-2
7310       endif
7311       do ll=1,3
7312         ggg1(ll)=eel_turn6*g_contij(ll,1)
7313         ggg2(ll)=eel_turn6*g_contij(ll,2)
7314         ghalf=0.5d0*ggg1(ll)
7315 cd        ghalf=0.0d0
7316         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7317      &    +ekont*derx_turn(ll,2,1)
7318         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7319         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7320      &    +ekont*derx_turn(ll,4,1)
7321         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7322         ghalf=0.5d0*ggg2(ll)
7323 cd        ghalf=0.0d0
7324         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7325      &    +ekont*derx_turn(ll,2,2)
7326         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7327         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7328      &    +ekont*derx_turn(ll,4,2)
7329         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7330       enddo
7331 cd      goto 1112
7332       do m=i+1,j-1
7333         do ll=1,3
7334           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7335         enddo
7336       enddo
7337       do m=k+1,l-1
7338         do ll=1,3
7339           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7340         enddo
7341       enddo
7342 1112  continue
7343       do m=i+2,j2
7344         do ll=1,3
7345           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7346         enddo
7347       enddo
7348       do m=k+2,l2
7349         do ll=1,3
7350           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7351         enddo
7352       enddo
7353 cd      do iii=1,nres-3
7354 cd        write (2,*) iii,g_corr6_loc(iii)
7355 cd      enddo
7356       endif
7357       eello_turn6=ekont*eel_turn6
7358 cd      write (2,*) 'ekont',ekont
7359 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7360       return
7361       end
7362 crc-------------------------------------------------
7363       SUBROUTINE MATVEC2(A1,V1,V2)
7364       implicit real*8 (a-h,o-z)
7365       include 'DIMENSIONS'
7366       DIMENSION A1(2,2),V1(2),V2(2)
7367 c      DO 1 I=1,2
7368 c        VI=0.0
7369 c        DO 3 K=1,2
7370 c    3     VI=VI+A1(I,K)*V1(K)
7371 c        Vaux(I)=VI
7372 c    1 CONTINUE
7373
7374       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7375       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7376
7377       v2(1)=vaux1
7378       v2(2)=vaux2
7379       END
7380 C---------------------------------------
7381       SUBROUTINE MATMAT2(A1,A2,A3)
7382       implicit real*8 (a-h,o-z)
7383       include 'DIMENSIONS'
7384       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7385 c      DIMENSION AI3(2,2)
7386 c        DO  J=1,2
7387 c          A3IJ=0.0
7388 c          DO K=1,2
7389 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7390 c          enddo
7391 c          A3(I,J)=A3IJ
7392 c       enddo
7393 c      enddo
7394
7395       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7396       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7397       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7398       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7399
7400       A3(1,1)=AI3_11
7401       A3(2,1)=AI3_21
7402       A3(1,2)=AI3_12
7403       A3(2,2)=AI3_22
7404       END
7405
7406 c-------------------------------------------------------------------------
7407       double precision function scalar2(u,v)
7408       implicit none
7409       double precision u(2),v(2)
7410       double precision sc
7411       integer i
7412       scalar2=u(1)*v(1)+u(2)*v(2)
7413       return
7414       end
7415
7416 C-----------------------------------------------------------------------------
7417
7418       subroutine transpose2(a,at)
7419       implicit none
7420       double precision a(2,2),at(2,2)
7421       at(1,1)=a(1,1)
7422       at(1,2)=a(2,1)
7423       at(2,1)=a(1,2)
7424       at(2,2)=a(2,2)
7425       return
7426       end
7427 c--------------------------------------------------------------------------
7428       subroutine transpose(n,a,at)
7429       implicit none
7430       integer n,i,j
7431       double precision a(n,n),at(n,n)
7432       do i=1,n
7433         do j=1,n
7434           at(j,i)=a(i,j)
7435         enddo
7436       enddo
7437       return
7438       end
7439 C---------------------------------------------------------------------------
7440       subroutine prodmat3(a1,a2,kk,transp,prod)
7441       implicit none
7442       integer i,j
7443       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
7444       logical transp
7445 crc      double precision auxmat(2,2),prod_(2,2)
7446
7447       if (transp) then
7448 crc        call transpose2(kk(1,1),auxmat(1,1))
7449 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
7450 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7451
7452            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
7453      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
7454            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
7455      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
7456            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
7457      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
7458            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
7459      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
7460
7461       else
7462 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
7463 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7464
7465            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
7466      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
7467            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
7468      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
7469            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
7470      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
7471            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
7472      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
7473
7474       endif
7475 c      call transpose2(a2(1,1),a2t(1,1))
7476
7477 crc      print *,transp
7478 crc      print *,((prod_(i,j),i=1,2),j=1,2)
7479 crc      print *,((prod(i,j),i=1,2),j=1,2)
7480
7481       return
7482       end
7483 C-----------------------------------------------------------------------------
7484       double precision function scalar(u,v)
7485       implicit none
7486       double precision u(3),v(3)
7487       double precision sc
7488       integer i
7489       sc=0.0d0
7490       do i=1,3
7491         sc=sc+u(i)*v(i)
7492       enddo
7493       scalar=sc
7494       return
7495       end
7496