source/wham/src-M/energy_p_new.F

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