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