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