source/wham/src-M/energy_p_new.F

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