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