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