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 <<<<<<< HEAD
4513 =======
4514 #ifdef DEBUG
4515           esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
4516 #endif
4517 >>>>>>> 3d6f9e7... Adam's changes to wham and cluster following previous commit
4518           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4519         enddo
4520         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
4521 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
4522 c     &gloc_sc(intertyp,i-3,icg)
4523         if (lprn)
4524      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4525      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4526      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
4527      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
4528         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
4529        enddo !intertyp
4530       enddo
4531
4532       return
4533       end
4534 c------------------------------------------------------------------------------
4535       subroutine multibody(ecorr)
4536 C This subroutine calculates multi-body contributions to energy following
4537 C the idea of Skolnick et al. If side chains I and J make a contact and
4538 C at the same time side chains I+1 and J+1 make a contact, an extra
4539 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
4540       implicit real*8 (a-h,o-z)
4541       include 'DIMENSIONS'
4542       include 'COMMON.IOUNITS'
4543       include 'COMMON.DERIV'
4544       include 'COMMON.INTERACT'
4545       include 'COMMON.CONTACTS'
4546       double precision gx(3),gx1(3)
4547       logical lprn
4548
4549 C Set lprn=.true. for debugging
4550       lprn=.false.
4551
4552       if (lprn) then
4553         write (iout,'(a)') 'Contact function values:'
4554         do i=nnt,nct-2
4555           write (iout,'(i2,20(1x,i2,f10.5))')
4556      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
4557         enddo
4558       endif
4559       ecorr=0.0D0
4560       do i=nnt,nct
4561         do j=1,3
4562           gradcorr(j,i)=0.0D0
4563           gradxorr(j,i)=0.0D0
4564         enddo
4565       enddo
4566       do i=nnt,nct-2
4567
4568         DO ISHIFT = 3,4
4569
4570         i1=i+ishift
4571         num_conti=num_cont(i)
4572         num_conti1=num_cont(i1)
4573         do jj=1,num_conti
4574           j=jcont(jj,i)
4575           do kk=1,num_conti1
4576             j1=jcont(kk,i1)
4577             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
4578 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4579 cd   &                   ' ishift=',ishift
4580 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
4581 C The system gains extra energy.
4582               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
4583             endif   ! j1==j+-ishift
4584           enddo     ! kk
4585         enddo       ! jj
4586
4587         ENDDO ! ISHIFT
4588
4589       enddo         ! i
4590       return
4591       end
4592 c------------------------------------------------------------------------------
4593       double precision function esccorr(i,j,k,l,jj,kk)
4594       implicit real*8 (a-h,o-z)
4595       include 'DIMENSIONS'
4596       include 'COMMON.IOUNITS'
4597       include 'COMMON.DERIV'
4598       include 'COMMON.INTERACT'
4599       include 'COMMON.CONTACTS'
4600       double precision gx(3),gx1(3)
4601       logical lprn
4602       lprn=.false.
4603       eij=facont(jj,i)
4604       ekl=facont(kk,k)
4605 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
4606 C Calculate the multi-body contribution to energy.
4607 C Calculate multi-body contributions to the gradient.
4608 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
4609 cd   & k,l,(gacont(m,kk,k),m=1,3)
4610       do m=1,3
4611         gx(m) =ekl*gacont(m,jj,i)
4612         gx1(m)=eij*gacont(m,kk,k)
4613         gradxorr(m,i)=gradxorr(m,i)-gx(m)
4614         gradxorr(m,j)=gradxorr(m,j)+gx(m)
4615         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
4616         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
4617       enddo
4618       do m=i,j-1
4619         do ll=1,3
4620           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
4621         enddo
4622       enddo
4623       do m=k,l-1
4624         do ll=1,3
4625           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
4626         enddo
4627       enddo
4628       esccorr=-eij*ekl
4629       return
4630       end
4631 c------------------------------------------------------------------------------
4632 #ifdef MPL
4633       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
4634       implicit real*8 (a-h,o-z)
4635       include 'DIMENSIONS'
4636       integer dimen1,dimen2,atom,indx
4637       double precision buffer(dimen1,dimen2)
4638       double precision zapas
4639       common /contacts_hb/ zapas(3,20,maxres,7),
4640      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4641      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4642       num_kont=num_cont_hb(atom)
4643       do i=1,num_kont
4644         do k=1,7
4645           do j=1,3
4646             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
4647           enddo ! j
4648         enddo ! k
4649         buffer(i,indx+22)=facont_hb(i,atom)
4650         buffer(i,indx+23)=ees0p(i,atom)
4651         buffer(i,indx+24)=ees0m(i,atom)
4652         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
4653       enddo ! i
4654       buffer(1,indx+26)=dfloat(num_kont)
4655       return
4656       end
4657 c------------------------------------------------------------------------------
4658       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
4659       implicit real*8 (a-h,o-z)
4660       include 'DIMENSIONS'
4661       integer dimen1,dimen2,atom,indx
4662       double precision buffer(dimen1,dimen2)
4663       double precision zapas
4664       common /contacts_hb/ zapas(3,20,maxres,7),
4665      &         facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
4666      &         num_cont_hb(maxres),jcont_hb(20,maxres)
4667       num_kont=buffer(1,indx+26)
4668       num_kont_old=num_cont_hb(atom)
4669       num_cont_hb(atom)=num_kont+num_kont_old
4670       do i=1,num_kont
4671         ii=i+num_kont_old
4672         do k=1,7
4673           do j=1,3
4674             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
4675           enddo ! j
4676         enddo ! k
4677         facont_hb(ii,atom)=buffer(i,indx+22)
4678         ees0p(ii,atom)=buffer(i,indx+23)
4679         ees0m(ii,atom)=buffer(i,indx+24)
4680         jcont_hb(ii,atom)=buffer(i,indx+25)
4681       enddo ! i
4682       return
4683       end
4684 c------------------------------------------------------------------------------
4685 #endif
4686       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
4687 C This subroutine calculates multi-body contributions to hydrogen-bonding
4688       implicit real*8 (a-h,o-z)
4689       include 'DIMENSIONS'
4690       include 'sizesclu.dat'
4691       include 'COMMON.IOUNITS'
4692 #ifdef MPL
4693       include 'COMMON.INFO'
4694 #endif
4695       include 'COMMON.FFIELD'
4696       include 'COMMON.DERIV'
4697       include 'COMMON.INTERACT'
4698       include 'COMMON.CONTACTS'
4699 #ifdef MPL
4700       parameter (max_cont=maxconts)
4701       parameter (max_dim=2*(8*3+2))
4702       parameter (msglen1=max_cont*max_dim*4)
4703       parameter (msglen2=2*msglen1)
4704       integer source,CorrelType,CorrelID,Error
4705       double precision buffer(max_cont,max_dim)
4706 #endif
4707       double precision gx(3),gx1(3)
4708       logical lprn,ldone
4709
4710 C Set lprn=.true. for debugging
4711       lprn=.false.
4712 #ifdef MPL
4713       n_corr=0
4714       n_corr1=0
4715       if (fgProcs.le.1) goto 30
4716       if (lprn) then
4717         write (iout,'(a)') 'Contact function values:'
4718         do i=nnt,nct-2
4719           write (iout,'(2i3,50(1x,i2,f5.2))')
4720      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4721      &    j=1,num_cont_hb(i))
4722         enddo
4723       endif
4724 C Caution! Following code assumes that electrostatic interactions concerning
4725 C a given atom are split among at most two processors!
4726       CorrelType=477
4727       CorrelID=MyID+1
4728       ldone=.false.
4729       do i=1,max_cont
4730         do j=1,max_dim
4731           buffer(i,j)=0.0D0
4732         enddo
4733       enddo
4734       mm=mod(MyRank,2)
4735 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
4736       if (mm) 20,20,10
4737    10 continue
4738 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
4739       if (MyRank.gt.0) then
4740 C Send correlation contributions to the preceding processor
4741         msglen=msglen1
4742         nn=num_cont_hb(iatel_s)
4743         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
4744 cd      write (iout,*) 'The BUFFER array:'
4745 cd      do i=1,nn
4746 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
4747 cd      enddo
4748         if (ielstart(iatel_s).gt.iatel_s+ispp) then
4749           msglen=msglen2
4750             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
4751 C Clear the contacts of the atom passed to the neighboring processor
4752         nn=num_cont_hb(iatel_s+1)
4753 cd      do i=1,nn
4754 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
4755 cd      enddo
4756             num_cont_hb(iatel_s)=0
4757         endif
4758 cd      write (iout,*) 'Processor ',MyID,MyRank,
4759 cd   & ' is sending correlation contribution to processor',MyID-1,
4760 cd   & ' msglen=',msglen
4761 cd      write (*,*) 'Processor ',MyID,MyRank,
4762 cd   & ' is sending correlation contribution to processor',MyID-1,
4763 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4764         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
4765 cd      write (iout,*) 'Processor ',MyID,
4766 cd   & ' has sent correlation contribution to processor',MyID-1,
4767 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4768 cd      write (*,*) 'Processor ',MyID,
4769 cd   & ' has sent correlation contribution to processor',MyID-1,
4770 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4771         msglen=msglen1
4772       endif ! (MyRank.gt.0)
4773       if (ldone) goto 30
4774       ldone=.true.
4775    20 continue
4776 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
4777       if (MyRank.lt.fgProcs-1) then
4778 C Receive correlation contributions from the next processor
4779         msglen=msglen1
4780         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
4781 cd      write (iout,*) 'Processor',MyID,
4782 cd   & ' is receiving correlation contribution from processor',MyID+1,
4783 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4784 cd      write (*,*) 'Processor',MyID,
4785 cd   & ' is receiving correlation contribution from processor',MyID+1,
4786 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4787         nbytes=-1
4788         do while (nbytes.le.0)
4789           call mp_probe(MyID+1,CorrelType,nbytes)
4790         enddo
4791 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
4792         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
4793 cd      write (iout,*) 'Processor',MyID,
4794 cd   & ' has received correlation contribution from processor',MyID+1,
4795 cd   & ' msglen=',msglen,' nbytes=',nbytes
4796 cd      write (iout,*) 'The received BUFFER array:'
4797 cd      do i=1,max_cont
4798 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
4799 cd      enddo
4800         if (msglen.eq.msglen1) then
4801           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
4802         else if (msglen.eq.msglen2)  then
4803           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
4804           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
4805         else
4806           write (iout,*)
4807      & 'ERROR!!!! message length changed while processing correlations.'
4808           write (*,*)
4809      & 'ERROR!!!! message length changed while processing correlations.'
4810           call mp_stopall(Error)
4811         endif ! msglen.eq.msglen1
4812       endif ! MyRank.lt.fgProcs-1
4813       if (ldone) goto 30
4814       ldone=.true.
4815       goto 10
4816    30 continue
4817 #endif
4818       if (lprn) then
4819         write (iout,'(a)') 'Contact function values:'
4820         do i=nnt,nct-2
4821           write (iout,'(2i3,50(1x,i2,f5.2))')
4822      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4823      &    j=1,num_cont_hb(i))
4824         enddo
4825       endif
4826       ecorr=0.0D0
4827 C Remove the loop below after debugging !!!
4828       do i=nnt,nct
4829         do j=1,3
4830           gradcorr(j,i)=0.0D0
4831           gradxorr(j,i)=0.0D0
4832         enddo
4833       enddo
4834 C Calculate the local-electrostatic correlation terms
4835       do i=iatel_s,iatel_e+1
4836         i1=i+1
4837         num_conti=num_cont_hb(i)
4838         num_conti1=num_cont_hb(i+1)
4839         do jj=1,num_conti
4840           j=jcont_hb(jj,i)
4841           do kk=1,num_conti1
4842             j1=jcont_hb(kk,i1)
4843 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4844 c     &         ' jj=',jj,' kk=',kk
4845             if (j1.eq.j+1 .or. j1.eq.j-1) then
4846 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
4847 C The system gains extra energy.
4848               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
4849               n_corr=n_corr+1
4850             else if (j1.eq.j) then
4851 C Contacts I-J and I-(J+1) occur simultaneously.
4852 C The system loses extra energy.
4853 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
4854             endif
4855           enddo ! kk
4856           do kk=1,num_conti
4857             j1=jcont_hb(kk,i)
4858 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4859 c    &         ' jj=',jj,' kk=',kk
4860             if (j1.eq.j+1) then
4861 C Contacts I-J and (I+1)-J occur simultaneously.
4862 C The system loses extra energy.
4863 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
4864             endif ! j1==j+1
4865           enddo ! kk
4866         enddo ! jj
4867       enddo ! i
4868       return
4869       end
4870 c------------------------------------------------------------------------------
4871       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
4872      &  n_corr1)
4873 C This subroutine calculates multi-body contributions to hydrogen-bonding
4874       implicit real*8 (a-h,o-z)
4875       include 'DIMENSIONS'
4876       include 'sizesclu.dat'
4877       include 'COMMON.IOUNITS'
4878 #ifdef MPL
4879       include 'COMMON.INFO'
4880 #endif
4881       include 'COMMON.FFIELD'
4882       include 'COMMON.DERIV'
4883       include 'COMMON.INTERACT'
4884       include 'COMMON.CONTACTS'
4885 #ifdef MPL
4886       parameter (max_cont=maxconts)
4887       parameter (max_dim=2*(8*3+2))
4888       parameter (msglen1=max_cont*max_dim*4)
4889       parameter (msglen2=2*msglen1)
4890       integer source,CorrelType,CorrelID,Error
4891       double precision buffer(max_cont,max_dim)
4892 #endif
4893       double precision gx(3),gx1(3)
4894       logical lprn,ldone
4895
4896 C Set lprn=.true. for debugging
4897       lprn=.false.
4898       eturn6=0.0d0
4899       ecorr6=0.0d0
4900 #ifdef MPL
4901       n_corr=0
4902       n_corr1=0
4903       if (fgProcs.le.1) goto 30
4904       if (lprn) then
4905         write (iout,'(a)') 'Contact function values:'
4906         do i=nnt,nct-2
4907           write (iout,'(2i3,50(1x,i2,f5.2))')
4908      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4909      &    j=1,num_cont_hb(i))
4910         enddo
4911       endif
4912 C Caution! Following code assumes that electrostatic interactions concerning
4913 C a given atom are split among at most two processors!
4914       CorrelType=477
4915       CorrelID=MyID+1
4916       ldone=.false.
4917       do i=1,max_cont
4918         do j=1,max_dim
4919           buffer(i,j)=0.0D0
4920         enddo
4921       enddo
4922       mm=mod(MyRank,2)
4923 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
4924       if (mm) 20,20,10
4925    10 continue
4926 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
4927       if (MyRank.gt.0) then
4928 C Send correlation contributions to the preceding processor
4929         msglen=msglen1
4930         nn=num_cont_hb(iatel_s)
4931         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
4932 cd      write (iout,*) 'The BUFFER array:'
4933 cd      do i=1,nn
4934 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
4935 cd      enddo
4936         if (ielstart(iatel_s).gt.iatel_s+ispp) then
4937           msglen=msglen2
4938             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
4939 C Clear the contacts of the atom passed to the neighboring processor
4940         nn=num_cont_hb(iatel_s+1)
4941 cd      do i=1,nn
4942 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
4943 cd      enddo
4944             num_cont_hb(iatel_s)=0
4945         endif
4946 cd      write (iout,*) 'Processor ',MyID,MyRank,
4947 cd   & ' is sending correlation contribution to processor',MyID-1,
4948 cd   & ' msglen=',msglen
4949 cd      write (*,*) 'Processor ',MyID,MyRank,
4950 cd   & ' is sending correlation contribution to processor',MyID-1,
4951 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4952         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
4953 cd      write (iout,*) 'Processor ',MyID,
4954 cd   & ' has sent correlation contribution to processor',MyID-1,
4955 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4956 cd      write (*,*) 'Processor ',MyID,
4957 cd   & ' has sent correlation contribution to processor',MyID-1,
4958 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4959         msglen=msglen1
4960       endif ! (MyRank.gt.0)
4961       if (ldone) goto 30
4962       ldone=.true.
4963    20 continue
4964 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
4965       if (MyRank.lt.fgProcs-1) then
4966 C Receive correlation contributions from the next processor
4967         msglen=msglen1
4968         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
4969 cd      write (iout,*) 'Processor',MyID,
4970 cd   & ' is receiving correlation contribution from processor',MyID+1,
4971 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4972 cd      write (*,*) 'Processor',MyID,
4973 cd   & ' is receiving correlation contribution from processor',MyID+1,
4974 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4975         nbytes=-1
4976         do while (nbytes.le.0)
4977           call mp_probe(MyID+1,CorrelType,nbytes)
4978         enddo
4979 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
4980         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
4981 cd      write (iout,*) 'Processor',MyID,
4982 cd   & ' has received correlation contribution from processor',MyID+1,
4983 cd   & ' msglen=',msglen,' nbytes=',nbytes
4984 cd      write (iout,*) 'The received BUFFER array:'
4985 cd      do i=1,max_cont
4986 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
4987 cd      enddo
4988         if (msglen.eq.msglen1) then
4989           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
4990         else if (msglen.eq.msglen2)  then
4991           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
4992           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
4993         else
4994           write (iout,*)
4995      & 'ERROR!!!! message length changed while processing correlations.'
4996           write (*,*)
4997      & 'ERROR!!!! message length changed while processing correlations.'
4998           call mp_stopall(Error)
4999         endif ! msglen.eq.msglen1
5000       endif ! MyRank.lt.fgProcs-1
5001       if (ldone) goto 30
5002       ldone=.true.
5003       goto 10
5004    30 continue
5005 #endif
5006       if (lprn) then
5007         write (iout,'(a)') 'Contact function values:'
5008         do i=nnt,nct-2
5009           write (iout,'(2i3,50(1x,i2,f5.2))')
5010      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5011      &    j=1,num_cont_hb(i))
5012         enddo
5013       endif
5014       ecorr=0.0D0
5015       ecorr5=0.0d0
5016       ecorr6=0.0d0
5017 C Remove the loop below after debugging !!!
5018       do i=nnt,nct
5019         do j=1,3
5020           gradcorr(j,i)=0.0D0
5021           gradxorr(j,i)=0.0D0
5022         enddo
5023       enddo
5024 C Calculate the dipole-dipole interaction energies
5025       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5026       do i=iatel_s,iatel_e+1
5027         num_conti=num_cont_hb(i)
5028         do jj=1,num_conti
5029           j=jcont_hb(jj,i)
5030           call dipole(i,j,jj)
5031         enddo
5032       enddo
5033       endif
5034 C Calculate the local-electrostatic correlation terms
5035       do i=iatel_s,iatel_e+1
5036         i1=i+1
5037         num_conti=num_cont_hb(i)
5038         num_conti1=num_cont_hb(i+1)
5039         do jj=1,num_conti
5040           j=jcont_hb(jj,i)
5041           do kk=1,num_conti1
5042             j1=jcont_hb(kk,i1)
5043 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5044 c     &         ' jj=',jj,' kk=',kk
5045             if (j1.eq.j+1 .or. j1.eq.j-1) then
5046 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5047 C The system gains extra energy.
5048               n_corr=n_corr+1
5049               sqd1=dsqrt(d_cont(jj,i))
5050               sqd2=dsqrt(d_cont(kk,i1))
5051               sred_geom = sqd1*sqd2
5052               IF (sred_geom.lt.cutoff_corr) THEN
5053                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5054      &            ekont,fprimcont)
5055 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5056 c     &         ' jj=',jj,' kk=',kk
5057                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5058                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5059                 do l=1,3
5060                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5061                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5062                 enddo
5063                 n_corr1=n_corr1+1
5064 cd               write (iout,*) 'sred_geom=',sred_geom,
5065 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5066                 call calc_eello(i,j,i+1,j1,jj,kk)
5067                 if (wcorr4.gt.0.0d0)
5068      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5069                 if (wcorr5.gt.0.0d0)
5070      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5071 c                print *,"wcorr5",ecorr5
5072 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5073 cd                write(2,*)'ijkl',i,j,i+1,j1
5074                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5075      &               .or. wturn6.eq.0.0d0))then
5076 c                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5077 c                  ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5078 c                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5079 c     &            'ecorr6=',ecorr6, wcorr6
5080 cd                write (iout,'(4e15.5)') sred_geom,
5081 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5082 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5083 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5084                 else if (wturn6.gt.0.0d0
5085      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5086 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5087                   eturn6=eturn6+eello_turn6(i,jj,kk)
5088 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5089                 endif
5090               ENDIF
5091 1111          continue
5092             else if (j1.eq.j) then
5093 C Contacts I-J and I-(J+1) occur simultaneously.
5094 C The system loses extra energy.
5095 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5096             endif
5097           enddo ! kk
5098           do kk=1,num_conti
5099             j1=jcont_hb(kk,i)
5100 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5101 c    &         ' jj=',jj,' kk=',kk
5102             if (j1.eq.j+1) then
5103 C Contacts I-J and (I+1)-J occur simultaneously.
5104 C The system loses extra energy.
5105 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5106             endif ! j1==j+1
5107           enddo ! kk
5108         enddo ! jj
5109       enddo ! i
5110       return
5111       end
5112 c------------------------------------------------------------------------------
5113       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5114       implicit real*8 (a-h,o-z)
5115       include 'DIMENSIONS'
5116       include 'COMMON.IOUNITS'
5117       include 'COMMON.DERIV'
5118       include 'COMMON.INTERACT'
5119       include 'COMMON.CONTACTS'
5120       double precision gx(3),gx1(3)
5121       logical lprn
5122       lprn=.false.
5123       eij=facont_hb(jj,i)
5124       ekl=facont_hb(kk,k)
5125       ees0pij=ees0p(jj,i)
5126       ees0pkl=ees0p(kk,k)
5127       ees0mij=ees0m(jj,i)
5128       ees0mkl=ees0m(kk,k)
5129       ekont=eij*ekl
5130       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5131 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5132 C Following 4 lines for diagnostics.
5133 cd    ees0pkl=0.0D0
5134 cd    ees0pij=1.0D0
5135 cd    ees0mkl=0.0D0
5136 cd    ees0mij=1.0D0
5137 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5138 c    &   ' and',k,l
5139 c     write (iout,*)'Contacts have occurred for peptide groups',
5140 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5141 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5142 C Calculate the multi-body contribution to energy.
5143       ecorr=ecorr+ekont*ees
5144       if (calc_grad) then
5145 C Calculate multi-body contributions to the gradient.
5146       do ll=1,3
5147         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5148         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5149      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5150      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5151         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5152      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5153      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5154         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5155         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5156      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5157      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5158         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5159      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5160      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5161       enddo
5162       do m=i+1,j-1
5163         do ll=1,3
5164           gradcorr(ll,m)=gradcorr(ll,m)+
5165      &     ees*ekl*gacont_hbr(ll,jj,i)-
5166      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5167      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5168         enddo
5169       enddo
5170       do m=k+1,l-1
5171         do ll=1,3
5172           gradcorr(ll,m)=gradcorr(ll,m)+
5173      &     ees*eij*gacont_hbr(ll,kk,k)-
5174      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5175      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5176         enddo
5177       enddo
5178       endif
5179       ehbcorr=ekont*ees
5180       return
5181       end
5182 C---------------------------------------------------------------------------
5183       subroutine dipole(i,j,jj)
5184       implicit real*8 (a-h,o-z)
5185       include 'DIMENSIONS'
5186       include 'sizesclu.dat'
5187       include 'COMMON.IOUNITS'
5188       include 'COMMON.CHAIN'
5189       include 'COMMON.FFIELD'
5190       include 'COMMON.DERIV'
5191       include 'COMMON.INTERACT'
5192       include 'COMMON.CONTACTS'
5193       include 'COMMON.TORSION'
5194       include 'COMMON.VAR'
5195       include 'COMMON.GEO'
5196       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5197      &  auxmat(2,2)
5198       iti1 = itortyp(itype(i+1))
5199       if (j.lt.nres-1) then
5200         itj1 = itortyp(itype(j+1))
5201       else
5202         itj1=ntortyp+1
5203       endif
5204       do iii=1,2
5205         dipi(iii,1)=Ub2(iii,i)
5206         dipderi(iii)=Ub2der(iii,i)
5207         dipi(iii,2)=b1(iii,iti1)
5208         dipj(iii,1)=Ub2(iii,j)
5209         dipderj(iii)=Ub2der(iii,j)
5210         dipj(iii,2)=b1(iii,itj1)
5211       enddo
5212       kkk=0
5213       do iii=1,2
5214         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5215         do jjj=1,2
5216           kkk=kkk+1
5217           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5218         enddo
5219       enddo
5220       if (.not.calc_grad) return
5221       do kkk=1,5
5222         do lll=1,3
5223           mmm=0
5224           do iii=1,2
5225             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5226      &        auxvec(1))
5227             do jjj=1,2
5228               mmm=mmm+1
5229               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5230             enddo
5231           enddo
5232         enddo
5233       enddo
5234       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5235       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5236       do iii=1,2
5237         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5238       enddo
5239       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5240       do iii=1,2
5241         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5242       enddo
5243       return
5244       end
5245 C---------------------------------------------------------------------------
5246       subroutine calc_eello(i,j,k,l,jj,kk)
5247 C
5248 C This subroutine computes matrices and vectors needed to calculate
5249 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5250 C
5251       implicit real*8 (a-h,o-z)
5252       include 'DIMENSIONS'
5253       include 'sizesclu.dat'
5254       include 'COMMON.IOUNITS'
5255       include 'COMMON.CHAIN'
5256       include 'COMMON.DERIV'
5257       include 'COMMON.INTERACT'
5258       include 'COMMON.CONTACTS'
5259       include 'COMMON.TORSION'
5260       include 'COMMON.VAR'
5261       include 'COMMON.GEO'
5262       include 'COMMON.FFIELD'
5263       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5264      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5265       logical lprn
5266       common /kutas/ lprn
5267 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5268 cd     & ' jj=',jj,' kk=',kk
5269 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5270       do iii=1,2
5271         do jjj=1,2
5272           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5273           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5274         enddo
5275       enddo
5276       call transpose2(aa1(1,1),aa1t(1,1))
5277       call transpose2(aa2(1,1),aa2t(1,1))
5278       do kkk=1,5
5279         do lll=1,3
5280           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5281      &      aa1tder(1,1,lll,kkk))
5282           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5283      &      aa2tder(1,1,lll,kkk))
5284         enddo
5285       enddo
5286       if (l.eq.j+1) then
5287 C parallel orientation of the two CA-CA-CA frames.
5288         if (i.gt.1) then
5289           iti=itortyp(itype(i))
5290         else
5291           iti=ntortyp+1
5292         endif
5293         itk1=itortyp(itype(k+1))
5294         itj=itortyp(itype(j))
5295         if (l.lt.nres-1) then
5296           itl1=itortyp(itype(l+1))
5297         else
5298           itl1=ntortyp+1
5299         endif
5300 C A1 kernel(j+1) A2T
5301 cd        do iii=1,2
5302 cd          write (iout,'(3f10.5,5x,3f10.5)')
5303 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5304 cd        enddo
5305         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5306      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5307      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5308 C Following matrices are needed only for 6-th order cumulants
5309         IF (wcorr6.gt.0.0d0) THEN
5310         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5311      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5312      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5313         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5314      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5315      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5316      &   ADtEAderx(1,1,1,1,1,1))
5317         lprn=.false.
5318         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5319      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5320      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5321      &   ADtEA1derx(1,1,1,1,1,1))
5322         ENDIF
5323 C End 6-th order cumulants
5324 cd        lprn=.false.
5325 cd        if (lprn) then
5326 cd        write (2,*) 'In calc_eello6'
5327 cd        do iii=1,2
5328 cd          write (2,*) 'iii=',iii
5329 cd          do kkk=1,5
5330 cd            write (2,*) 'kkk=',kkk
5331 cd            do jjj=1,2
5332 cd              write (2,'(3(2f10.5),5x)')
5333 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5334 cd            enddo
5335 cd          enddo
5336 cd        enddo
5337 cd        endif
5338         call transpose2(EUgder(1,1,k),auxmat(1,1))
5339         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5340         call transpose2(EUg(1,1,k),auxmat(1,1))
5341         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5342         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5343         do iii=1,2
5344           do kkk=1,5
5345             do lll=1,3
5346               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5347      &          EAEAderx(1,1,lll,kkk,iii,1))
5348             enddo
5349           enddo
5350         enddo
5351 C A1T kernel(i+1) A2
5352         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5353      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5354      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5355 C Following matrices are needed only for 6-th order cumulants
5356         IF (wcorr6.gt.0.0d0) THEN
5357         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5358      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5359      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5360         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5361      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
5362      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5363      &   ADtEAderx(1,1,1,1,1,2))
5364         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5365      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5366      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5367      &   ADtEA1derx(1,1,1,1,1,2))
5368         ENDIF
5369 C End 6-th order cumulants
5370         call transpose2(EUgder(1,1,l),auxmat(1,1))
5371         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5372         call transpose2(EUg(1,1,l),auxmat(1,1))
5373         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5374         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5375         do iii=1,2
5376           do kkk=1,5
5377             do lll=1,3
5378               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5379      &          EAEAderx(1,1,lll,kkk,iii,2))
5380             enddo
5381           enddo
5382         enddo
5383 C AEAb1 and AEAb2
5384 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5385 C They are needed only when the fifth- or the sixth-order cumulants are
5386 C indluded.
5387         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5388         call transpose2(AEA(1,1,1),auxmat(1,1))
5389         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5390         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5391         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5392         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5393         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5394         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5395         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5396         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5397         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5398         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5399         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5400         call transpose2(AEA(1,1,2),auxmat(1,1))
5401         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5402         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5403         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5404         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5405         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5406         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5407         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5408         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5409         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5410         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5411         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5412 C Calculate the Cartesian derivatives of the vectors.
5413         do iii=1,2
5414           do kkk=1,5
5415             do lll=1,3
5416               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5417               call matvec2(auxmat(1,1),b1(1,iti),
5418      &          AEAb1derx(1,lll,kkk,iii,1,1))
5419               call matvec2(auxmat(1,1),Ub2(1,i),
5420      &          AEAb2derx(1,lll,kkk,iii,1,1))
5421               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5422      &          AEAb1derx(1,lll,kkk,iii,2,1))
5423               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5424      &          AEAb2derx(1,lll,kkk,iii,2,1))
5425               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5426               call matvec2(auxmat(1,1),b1(1,itj),
5427      &          AEAb1derx(1,lll,kkk,iii,1,2))
5428               call matvec2(auxmat(1,1),Ub2(1,j),
5429      &          AEAb2derx(1,lll,kkk,iii,1,2))
5430               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
5431      &          AEAb1derx(1,lll,kkk,iii,2,2))
5432               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
5433      &          AEAb2derx(1,lll,kkk,iii,2,2))
5434             enddo
5435           enddo
5436         enddo
5437         ENDIF
5438 C End vectors
5439       else
5440 C Antiparallel orientation of the two CA-CA-CA frames.
5441         if (i.gt.1) then
5442           iti=itortyp(itype(i))
5443         else
5444           iti=ntortyp+1
5445         endif
5446         itk1=itortyp(itype(k+1))
5447         itl=itortyp(itype(l))
5448         itj=itortyp(itype(j))
5449         if (j.lt.nres-1) then
5450           itj1=itortyp(itype(j+1))
5451         else
5452           itj1=ntortyp+1
5453         endif
5454 C A2 kernel(j-1)T A1T
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.,EUg(1,1,j),EUgder(1,1,j),
5457      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5458 C Following matrices are needed only for 6-th order cumulants
5459         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5460      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5461         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5462      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
5463      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5464         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5465      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
5466      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5467      &   ADtEAderx(1,1,1,1,1,1))
5468         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5469      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
5470      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5471      &   ADtEA1derx(1,1,1,1,1,1))
5472         ENDIF
5473 C End 6-th order cumulants
5474         call transpose2(EUgder(1,1,k),auxmat(1,1))
5475         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5476         call transpose2(EUg(1,1,k),auxmat(1,1))
5477         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5478         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5479         do iii=1,2
5480           do kkk=1,5
5481             do lll=1,3
5482               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5483      &          EAEAderx(1,1,lll,kkk,iii,1))
5484             enddo
5485           enddo
5486         enddo
5487 C A2T kernel(i+1)T A1
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.,EUg(1,1,k),EUgder(1,1,k),
5490      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5491 C Following matrices are needed only for 6-th order cumulants
5492         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5493      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5494         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5495      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
5496      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5497         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5498      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
5499      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5500      &   ADtEAderx(1,1,1,1,1,2))
5501         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5502      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
5503      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5504      &   ADtEA1derx(1,1,1,1,1,2))
5505         ENDIF
5506 C End 6-th order cumulants
5507         call transpose2(EUgder(1,1,j),auxmat(1,1))
5508         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
5509         call transpose2(EUg(1,1,j),auxmat(1,1))
5510         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5511         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5512         do iii=1,2
5513           do kkk=1,5
5514             do lll=1,3
5515               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5516      &          EAEAderx(1,1,lll,kkk,iii,2))
5517             enddo
5518           enddo
5519         enddo
5520 C AEAb1 and AEAb2
5521 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5522 C They are needed only when the fifth- or the sixth-order cumulants are
5523 C indluded.
5524         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
5525      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
5526         call transpose2(AEA(1,1,1),auxmat(1,1))
5527         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5528         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5529         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5530         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5531         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5532         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5533         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5534         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5535         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5536         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5537         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5538         call transpose2(AEA(1,1,2),auxmat(1,1))
5539         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
5540         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
5541         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
5542         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5543         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
5544         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
5545         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
5546         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
5547         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
5548         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
5549         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
5550 C Calculate the Cartesian derivatives of the vectors.
5551         do iii=1,2
5552           do kkk=1,5
5553             do lll=1,3
5554               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5555               call matvec2(auxmat(1,1),b1(1,iti),
5556      &          AEAb1derx(1,lll,kkk,iii,1,1))
5557               call matvec2(auxmat(1,1),Ub2(1,i),
5558      &          AEAb2derx(1,lll,kkk,iii,1,1))
5559               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5560      &          AEAb1derx(1,lll,kkk,iii,2,1))
5561               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5562      &          AEAb2derx(1,lll,kkk,iii,2,1))
5563               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5564               call matvec2(auxmat(1,1),b1(1,itl),
5565      &          AEAb1derx(1,lll,kkk,iii,1,2))
5566               call matvec2(auxmat(1,1),Ub2(1,l),
5567      &          AEAb2derx(1,lll,kkk,iii,1,2))
5568               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
5569      &          AEAb1derx(1,lll,kkk,iii,2,2))
5570               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
5571      &          AEAb2derx(1,lll,kkk,iii,2,2))
5572             enddo
5573           enddo
5574         enddo
5575         ENDIF
5576 C End vectors
5577       endif
5578       return
5579       end
5580 C---------------------------------------------------------------------------
5581       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
5582      &  KK,KKderg,AKA,AKAderg,AKAderx)
5583       implicit none
5584       integer nderg
5585       logical transp
5586       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
5587      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
5588      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
5589       integer iii,kkk,lll
5590       integer jjj,mmm
5591       logical lprn
5592       common /kutas/ lprn
5593       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
5594       do iii=1,nderg
5595         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
5596      &    AKAderg(1,1,iii))
5597       enddo
5598 cd      if (lprn) write (2,*) 'In kernel'
5599       do kkk=1,5
5600 cd        if (lprn) write (2,*) 'kkk=',kkk
5601         do lll=1,3
5602           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
5603      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
5604 cd          if (lprn) then
5605 cd            write (2,*) 'lll=',lll
5606 cd            write (2,*) 'iii=1'
5607 cd            do jjj=1,2
5608 cd              write (2,'(3(2f10.5),5x)')
5609 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
5610 cd            enddo
5611 cd          endif
5612           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
5613      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
5614 cd          if (lprn) then
5615 cd            write (2,*) 'lll=',lll
5616 cd            write (2,*) 'iii=2'
5617 cd            do jjj=1,2
5618 cd              write (2,'(3(2f10.5),5x)')
5619 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
5620 cd            enddo
5621 cd          endif
5622         enddo
5623       enddo
5624       return
5625       end
5626 C---------------------------------------------------------------------------
5627       double precision function eello4(i,j,k,l,jj,kk)
5628       implicit real*8 (a-h,o-z)
5629       include 'DIMENSIONS'
5630       include 'sizesclu.dat'
5631       include 'COMMON.IOUNITS'
5632       include 'COMMON.CHAIN'
5633       include 'COMMON.DERIV'
5634       include 'COMMON.INTERACT'
5635       include 'COMMON.CONTACTS'
5636       include 'COMMON.TORSION'
5637       include 'COMMON.VAR'
5638       include 'COMMON.GEO'
5639       double precision pizda(2,2),ggg1(3),ggg2(3)
5640 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
5641 cd        eello4=0.0d0
5642 cd        return
5643 cd      endif
5644 cd      print *,'eello4:',i,j,k,l,jj,kk
5645 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
5646 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
5647 cold      eij=facont_hb(jj,i)
5648 cold      ekl=facont_hb(kk,k)
5649 cold      ekont=eij*ekl
5650       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
5651       if (calc_grad) then
5652 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
5653       gcorr_loc(k-1)=gcorr_loc(k-1)
5654      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
5655       if (l.eq.j+1) then
5656         gcorr_loc(l-1)=gcorr_loc(l-1)
5657      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5658       else
5659         gcorr_loc(j-1)=gcorr_loc(j-1)
5660      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5661       endif
5662       do iii=1,2
5663         do kkk=1,5
5664           do lll=1,3
5665             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
5666      &                        -EAEAderx(2,2,lll,kkk,iii,1)
5667 cd            derx(lll,kkk,iii)=0.0d0
5668           enddo
5669         enddo
5670       enddo
5671 cd      gcorr_loc(l-1)=0.0d0
5672 cd      gcorr_loc(j-1)=0.0d0
5673 cd      gcorr_loc(k-1)=0.0d0
5674 cd      eel4=1.0d0
5675 cd      write (iout,*)'Contacts have occurred for peptide groups',
5676 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
5677 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
5678       if (j.lt.nres-1) then
5679         j1=j+1
5680         j2=j-1
5681       else
5682         j1=j-1
5683         j2=j-2
5684       endif
5685       if (l.lt.nres-1) then
5686         l1=l+1
5687         l2=l-1
5688       else
5689         l1=l-1
5690         l2=l-2
5691       endif
5692       do ll=1,3
5693 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
5694         ggg1(ll)=eel4*g_contij(ll,1)
5695         ggg2(ll)=eel4*g_contij(ll,2)
5696         ghalf=0.5d0*ggg1(ll)
5697 cd        ghalf=0.0d0
5698         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
5699         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
5700         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
5701         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
5702 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
5703         ghalf=0.5d0*ggg2(ll)
5704 cd        ghalf=0.0d0
5705         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
5706         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
5707         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
5708         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
5709       enddo
5710 cd      goto 1112
5711       do m=i+1,j-1
5712         do ll=1,3
5713 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
5714           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
5715         enddo
5716       enddo
5717       do m=k+1,l-1
5718         do ll=1,3
5719 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
5720           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
5721         enddo
5722       enddo
5723 1112  continue
5724       do m=i+2,j2
5725         do ll=1,3
5726           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
5727         enddo
5728       enddo
5729       do m=k+2,l2
5730         do ll=1,3
5731           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
5732         enddo
5733       enddo
5734 cd      do iii=1,nres-3
5735 cd        write (2,*) iii,gcorr_loc(iii)
5736 cd      enddo
5737       endif
5738       eello4=ekont*eel4
5739 cd      write (2,*) 'ekont',ekont
5740 cd      write (iout,*) 'eello4',ekont*eel4
5741       return
5742       end
5743 C---------------------------------------------------------------------------
5744       double precision function eello5(i,j,k,l,jj,kk)
5745       implicit real*8 (a-h,o-z)
5746       include 'DIMENSIONS'
5747       include 'sizesclu.dat'
5748       include 'COMMON.IOUNITS'
5749       include 'COMMON.CHAIN'
5750       include 'COMMON.DERIV'
5751       include 'COMMON.INTERACT'
5752       include 'COMMON.CONTACTS'
5753       include 'COMMON.TORSION'
5754       include 'COMMON.VAR'
5755       include 'COMMON.GEO'
5756       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
5757       double precision ggg1(3),ggg2(3)
5758 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5759 C                                                                              C
5760 C                            Parallel chains                                   C
5761 C                                                                              C
5762 C          o             o                   o             o                   C
5763 C         /l\           / \             \   / \           / \   /              C
5764 C        /   \         /   \             \ /   \         /   \ /               C
5765 C       j| o |l1       | o |              o| o |         | o |o                C
5766 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
5767 C      \i/   \         /   \ /             /   \         /   \                 C
5768 C       o    k1             o                                                  C
5769 C         (I)          (II)                (III)          (IV)                 C
5770 C                                                                              C
5771 C      eello5_1        eello5_2            eello5_3       eello5_4             C
5772 C                                                                              C
5773 C                            Antiparallel chains                               C
5774 C                                                                              C
5775 C          o             o                   o             o                   C
5776 C         /j\           / \             \   / \           / \   /              C
5777 C        /   \         /   \             \ /   \         /   \ /               C
5778 C      j1| o |l        | o |              o| o |         | o |o                C
5779 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
5780 C      \i/   \         /   \ /             /   \         /   \                 C
5781 C       o     k1            o                                                  C
5782 C         (I)          (II)                (III)          (IV)                 C
5783 C                                                                              C
5784 C      eello5_1        eello5_2            eello5_3       eello5_4             C
5785 C                                                                              C
5786 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
5787 C                                                                              C
5788 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5789 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
5790 cd        eello5=0.0d0
5791 cd        return
5792 cd      endif
5793 cd      write (iout,*)
5794 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
5795 cd     &   ' and',k,l
5796       itk=itortyp(itype(k))
5797       itl=itortyp(itype(l))
5798       itj=itortyp(itype(j))
5799       eello5_1=0.0d0
5800       eello5_2=0.0d0
5801       eello5_3=0.0d0
5802       eello5_4=0.0d0
5803 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
5804 cd     &   eel5_3_num,eel5_4_num)
5805       do iii=1,2
5806         do kkk=1,5
5807           do lll=1,3
5808             derx(lll,kkk,iii)=0.0d0
5809           enddo
5810         enddo
5811       enddo
5812 cd      eij=facont_hb(jj,i)
5813 cd      ekl=facont_hb(kk,k)
5814 cd      ekont=eij*ekl
5815 cd      write (iout,*)'Contacts have occurred for peptide groups',
5816 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
5817 cd      goto 1111
5818 C Contribution from the graph I.
5819 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
5820 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
5821       call transpose2(EUg(1,1,k),auxmat(1,1))
5822       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
5823       vv(1)=pizda(1,1)-pizda(2,2)
5824       vv(2)=pizda(1,2)+pizda(2,1)
5825       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
5826      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
5827       if (calc_grad) then
5828 C Explicit gradient in virtual-dihedral angles.
5829       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
5830      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
5831      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
5832       call transpose2(EUgder(1,1,k),auxmat1(1,1))
5833       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
5834       vv(1)=pizda(1,1)-pizda(2,2)
5835       vv(2)=pizda(1,2)+pizda(2,1)
5836       g_corr5_loc(k-1)=g_corr5_loc(k-1)
5837      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
5838      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5839       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
5840       vv(1)=pizda(1,1)-pizda(2,2)
5841       vv(2)=pizda(1,2)+pizda(2,1)
5842       if (l.eq.j+1) then
5843         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
5844      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
5845      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5846       else
5847         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
5848      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
5849      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5850       endif
5851 C Cartesian gradient
5852       do iii=1,2
5853         do kkk=1,5
5854           do lll=1,3
5855             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
5856      &        pizda(1,1))
5857             vv(1)=pizda(1,1)-pizda(2,2)
5858             vv(2)=pizda(1,2)+pizda(2,1)
5859             derx(lll,kkk,iii)=derx(lll,kkk,iii)
5860      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
5861      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
5862           enddo
5863         enddo
5864       enddo
5865 c      goto 1112
5866       endif
5867 c1111  continue
5868 C Contribution from graph II
5869       call transpose2(EE(1,1,itk),auxmat(1,1))
5870       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
5871       vv(1)=pizda(1,1)+pizda(2,2)
5872       vv(2)=pizda(2,1)-pizda(1,2)
5873       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
5874      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
5875       if (calc_grad) then
5876 C Explicit gradient in virtual-dihedral angles.
5877       g_corr5_loc(k-1)=g_corr5_loc(k-1)
5878      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
5879       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
5880       vv(1)=pizda(1,1)+pizda(2,2)
5881       vv(2)=pizda(2,1)-pizda(1,2)
5882       if (l.eq.j+1) then
5883         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5884      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
5885      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
5886       else
5887         g_corr5_loc(j-1)=g_corr5_loc(j-1)
5888      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
5889      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
5890       endif
5891 C Cartesian gradient
5892       do iii=1,2
5893         do kkk=1,5
5894           do lll=1,3
5895             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5896      &        pizda(1,1))
5897             vv(1)=pizda(1,1)+pizda(2,2)
5898             vv(2)=pizda(2,1)-pizda(1,2)
5899             derx(lll,kkk,iii)=derx(lll,kkk,iii)
5900      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
5901      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
5902           enddo
5903         enddo
5904       enddo
5905 cd      goto 1112
5906       endif
5907 cd1111  continue
5908       if (l.eq.j+1) then
5909 cd        goto 1110
5910 C Parallel orientation
5911 C Contribution from graph III
5912         call transpose2(EUg(1,1,l),auxmat(1,1))
5913         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
5914         vv(1)=pizda(1,1)-pizda(2,2)
5915         vv(2)=pizda(1,2)+pizda(2,1)
5916         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
5917      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
5918         if (calc_grad) then
5919 C Explicit gradient in virtual-dihedral angles.
5920         g_corr5_loc(j-1)=g_corr5_loc(j-1)
5921      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
5922      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
5923         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
5924         vv(1)=pizda(1,1)-pizda(2,2)
5925         vv(2)=pizda(1,2)+pizda(2,1)
5926         g_corr5_loc(k-1)=g_corr5_loc(k-1)
5927      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
5928      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
5929         call transpose2(EUgder(1,1,l),auxmat1(1,1))
5930         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
5931         vv(1)=pizda(1,1)-pizda(2,2)
5932         vv(2)=pizda(1,2)+pizda(2,1)
5933         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5934      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
5935      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
5936 C Cartesian gradient
5937         do iii=1,2
5938           do kkk=1,5
5939             do lll=1,3
5940               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
5941      &          pizda(1,1))
5942               vv(1)=pizda(1,1)-pizda(2,2)
5943               vv(2)=pizda(1,2)+pizda(2,1)
5944               derx(lll,kkk,iii)=derx(lll,kkk,iii)
5945      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
5946      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
5947             enddo
5948           enddo
5949         enddo
5950 cd        goto 1112
5951         endif
5952 C Contribution from graph IV
5953 cd1110    continue
5954         call transpose2(EE(1,1,itl),auxmat(1,1))
5955         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
5956         vv(1)=pizda(1,1)+pizda(2,2)
5957         vv(2)=pizda(2,1)-pizda(1,2)
5958         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
5959      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
5960         if (calc_grad) then
5961 C Explicit gradient in virtual-dihedral angles.
5962         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5963      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
5964         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
5965         vv(1)=pizda(1,1)+pizda(2,2)
5966         vv(2)=pizda(2,1)-pizda(1,2)
5967         g_corr5_loc(k-1)=g_corr5_loc(k-1)
5968      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
5969      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
5970 C Cartesian gradient
5971         do iii=1,2
5972           do kkk=1,5
5973             do lll=1,3
5974               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5975      &          pizda(1,1))
5976               vv(1)=pizda(1,1)+pizda(2,2)
5977               vv(2)=pizda(2,1)-pizda(1,2)
5978               derx(lll,kkk,iii)=derx(lll,kkk,iii)
5979      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
5980      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
5981             enddo
5982           enddo
5983         enddo
5984         endif
5985       else
5986 C Antiparallel orientation
5987 C Contribution from graph III
5988 c        goto 1110
5989         call transpose2(EUg(1,1,j),auxmat(1,1))
5990         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
5991         vv(1)=pizda(1,1)-pizda(2,2)
5992         vv(2)=pizda(1,2)+pizda(2,1)
5993         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
5994      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
5995         if (calc_grad) then
5996 C Explicit gradient in virtual-dihedral angles.
5997         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5998      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
5999      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6000         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6001         vv(1)=pizda(1,1)-pizda(2,2)
6002         vv(2)=pizda(1,2)+pizda(2,1)
6003         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6004      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6005      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6006         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6007         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6008         vv(1)=pizda(1,1)-pizda(2,2)
6009         vv(2)=pizda(1,2)+pizda(2,1)
6010         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6011      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6012      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6013 C Cartesian gradient
6014         do iii=1,2
6015           do kkk=1,5
6016             do lll=1,3
6017               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6018      &          pizda(1,1))
6019               vv(1)=pizda(1,1)-pizda(2,2)
6020               vv(2)=pizda(1,2)+pizda(2,1)
6021               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6022      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6023      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6024             enddo
6025           enddo
6026         enddo
6027 cd        goto 1112
6028         endif
6029 C Contribution from graph IV
6030 1110    continue
6031         call transpose2(EE(1,1,itj),auxmat(1,1))
6032         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6033         vv(1)=pizda(1,1)+pizda(2,2)
6034         vv(2)=pizda(2,1)-pizda(1,2)
6035         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6036      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6037         if (calc_grad) then
6038 C Explicit gradient in virtual-dihedral angles.
6039         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6040      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6041         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6042         vv(1)=pizda(1,1)+pizda(2,2)
6043         vv(2)=pizda(2,1)-pizda(1,2)
6044         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6045      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6046      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6047 C Cartesian gradient
6048         do iii=1,2
6049           do kkk=1,5
6050             do lll=1,3
6051               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6052      &          pizda(1,1))
6053               vv(1)=pizda(1,1)+pizda(2,2)
6054               vv(2)=pizda(2,1)-pizda(1,2)
6055               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6056      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6057      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6058             enddo
6059           enddo
6060         enddo
6061       endif
6062       endif
6063 1112  continue
6064       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6065 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6066 cd        write (2,*) 'ijkl',i,j,k,l
6067 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6068 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6069 cd      endif
6070 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6071 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6072 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6073 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6074       if (calc_grad) then
6075       if (j.lt.nres-1) then
6076         j1=j+1
6077         j2=j-1
6078       else
6079         j1=j-1
6080         j2=j-2
6081       endif
6082       if (l.lt.nres-1) then
6083         l1=l+1
6084         l2=l-1
6085       else
6086         l1=l-1
6087         l2=l-2
6088       endif
6089 cd      eij=1.0d0
6090 cd      ekl=1.0d0
6091 cd      ekont=1.0d0
6092 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6093       do ll=1,3
6094         ggg1(ll)=eel5*g_contij(ll,1)
6095         ggg2(ll)=eel5*g_contij(ll,2)
6096 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6097         ghalf=0.5d0*ggg1(ll)
6098 cd        ghalf=0.0d0
6099         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6100         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6101         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6102         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6103 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6104         ghalf=0.5d0*ggg2(ll)
6105 cd        ghalf=0.0d0
6106         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6107         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6108         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6109         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6110       enddo
6111 cd      goto 1112
6112       do m=i+1,j-1
6113         do ll=1,3
6114 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6115           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6116         enddo
6117       enddo
6118       do m=k+1,l-1
6119         do ll=1,3
6120 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6121           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6122         enddo
6123       enddo
6124 c1112  continue
6125       do m=i+2,j2
6126         do ll=1,3
6127           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6128         enddo
6129       enddo
6130       do m=k+2,l2
6131         do ll=1,3
6132           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6133         enddo
6134       enddo
6135 cd      do iii=1,nres-3
6136 cd        write (2,*) iii,g_corr5_loc(iii)
6137 cd      enddo
6138       endif
6139       eello5=ekont*eel5
6140 cd      write (2,*) 'ekont',ekont
6141 cd      write (iout,*) 'eello5',ekont*eel5
6142       return
6143       end
6144 c--------------------------------------------------------------------------
6145       double precision function eello6(i,j,k,l,jj,kk)
6146       implicit real*8 (a-h,o-z)
6147       include 'DIMENSIONS'
6148       include 'sizesclu.dat'
6149       include 'COMMON.IOUNITS'
6150       include 'COMMON.CHAIN'
6151       include 'COMMON.DERIV'
6152       include 'COMMON.INTERACT'
6153       include 'COMMON.CONTACTS'
6154       include 'COMMON.TORSION'
6155       include 'COMMON.VAR'
6156       include 'COMMON.GEO'
6157       include 'COMMON.FFIELD'
6158       double precision ggg1(3),ggg2(3)
6159 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6160 cd        eello6=0.0d0
6161 cd        return
6162 cd      endif
6163 cd      write (iout,*)
6164 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6165 cd     &   ' and',k,l
6166       eello6_1=0.0d0
6167       eello6_2=0.0d0
6168       eello6_3=0.0d0
6169       eello6_4=0.0d0
6170       eello6_5=0.0d0
6171       eello6_6=0.0d0
6172 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6173 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6174       do iii=1,2
6175         do kkk=1,5
6176           do lll=1,3
6177             derx(lll,kkk,iii)=0.0d0
6178           enddo
6179         enddo
6180       enddo
6181 cd      eij=facont_hb(jj,i)
6182 cd      ekl=facont_hb(kk,k)
6183 cd      ekont=eij*ekl
6184 cd      eij=1.0d0
6185 cd      ekl=1.0d0
6186 cd      ekont=1.0d0
6187       if (l.eq.j+1) then
6188         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6189         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6190         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6191         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6192         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6193         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6194       else
6195         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6196         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6197         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6198         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6199         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6200           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6201         else
6202           eello6_5=0.0d0
6203         endif
6204         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6205       endif
6206 C If turn contributions are considered, they will be handled separately.
6207       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6208 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6209 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6210 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6211 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6212 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6213 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6214 cd      goto 1112
6215       if (calc_grad) then
6216       if (j.lt.nres-1) then
6217         j1=j+1
6218         j2=j-1
6219       else
6220         j1=j-1
6221         j2=j-2
6222       endif
6223       if (l.lt.nres-1) then
6224         l1=l+1
6225         l2=l-1
6226       else
6227         l1=l-1
6228         l2=l-2
6229       endif
6230       do ll=1,3
6231         ggg1(ll)=eel6*g_contij(ll,1)
6232         ggg2(ll)=eel6*g_contij(ll,2)
6233 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6234         ghalf=0.5d0*ggg1(ll)
6235 cd        ghalf=0.0d0
6236         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6237         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6238         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6239         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6240         ghalf=0.5d0*ggg2(ll)
6241 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6242 cd        ghalf=0.0d0
6243         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6244         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6245         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6246         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6247       enddo
6248 cd      goto 1112
6249       do m=i+1,j-1
6250         do ll=1,3
6251 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6252           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6253         enddo
6254       enddo
6255       do m=k+1,l-1
6256         do ll=1,3
6257 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6258           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6259         enddo
6260       enddo
6261 1112  continue
6262       do m=i+2,j2
6263         do ll=1,3
6264           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6265         enddo
6266       enddo
6267       do m=k+2,l2
6268         do ll=1,3
6269           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6270         enddo
6271       enddo
6272 cd      do iii=1,nres-3
6273 cd        write (2,*) iii,g_corr6_loc(iii)
6274 cd      enddo
6275       endif
6276       eello6=ekont*eel6
6277 cd      write (2,*) 'ekont',ekont
6278 cd      write (iout,*) 'eello6',ekont*eel6
6279       return
6280       end
6281 c--------------------------------------------------------------------------
6282       double precision function eello6_graph1(i,j,k,l,imat,swap)
6283       implicit real*8 (a-h,o-z)
6284       include 'DIMENSIONS'
6285       include 'sizesclu.dat'
6286       include 'COMMON.IOUNITS'
6287       include 'COMMON.CHAIN'
6288       include 'COMMON.DERIV'
6289       include 'COMMON.INTERACT'
6290       include 'COMMON.CONTACTS'
6291       include 'COMMON.TORSION'
6292       include 'COMMON.VAR'
6293       include 'COMMON.GEO'
6294       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6295       logical swap
6296       logical lprn
6297       common /kutas/ lprn
6298 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6299 C                                                                              C
6300 C      Parallel       Antiparallel                                             C
6301 C                                                                              C
6302 C          o             o                                                     C
6303 C         /l\           /j\                                                    C
6304 C        /   \         /   \                                                   C
6305 C       /| o |         | o |\                                                  C
6306 C     \ j|/k\|  /   \  |/k\|l /                                                C
6307 C      \ /   \ /     \ /   \ /                                                 C
6308 C       o     o       o     o                                                  C
6309 C       i             i                                                        C
6310 C                                                                              C
6311 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6312       itk=itortyp(itype(k))
6313       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6314       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6315       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6316       call transpose2(EUgC(1,1,k),auxmat(1,1))
6317       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6318       vv1(1)=pizda1(1,1)-pizda1(2,2)
6319       vv1(2)=pizda1(1,2)+pizda1(2,1)
6320       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6321       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6322       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6323       s5=scalar2(vv(1),Dtobr2(1,i))
6324 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6325       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6326       if (.not. calc_grad) return
6327       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6328      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6329      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6330      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6331      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6332      & +scalar2(vv(1),Dtobr2der(1,i)))
6333       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6334       vv1(1)=pizda1(1,1)-pizda1(2,2)
6335       vv1(2)=pizda1(1,2)+pizda1(2,1)
6336       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6337       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6338       if (l.eq.j+1) then
6339         g_corr6_loc(l-1)=g_corr6_loc(l-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       else
6345         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6346      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6347      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6348      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6349      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6350       endif
6351       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6352       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6353       vv1(1)=pizda1(1,1)-pizda1(2,2)
6354       vv1(2)=pizda1(1,2)+pizda1(2,1)
6355       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6356      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6357      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6358      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6359       do iii=1,2
6360         if (swap) then
6361           ind=3-iii
6362         else
6363           ind=iii
6364         endif
6365         do kkk=1,5
6366           do lll=1,3
6367             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6368             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6369             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6370             call transpose2(EUgC(1,1,k),auxmat(1,1))
6371             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6372      &        pizda1(1,1))
6373             vv1(1)=pizda1(1,1)-pizda1(2,2)
6374             vv1(2)=pizda1(1,2)+pizda1(2,1)
6375             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6376             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6377      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6378             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6379      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6380             s5=scalar2(vv(1),Dtobr2(1,i))
6381             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6382           enddo
6383         enddo
6384       enddo
6385       return
6386       end
6387 c----------------------------------------------------------------------------
6388       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6389       implicit real*8 (a-h,o-z)
6390       include 'DIMENSIONS'
6391       include 'sizesclu.dat'
6392       include 'COMMON.IOUNITS'
6393       include 'COMMON.CHAIN'
6394       include 'COMMON.DERIV'
6395       include 'COMMON.INTERACT'
6396       include 'COMMON.CONTACTS'
6397       include 'COMMON.TORSION'
6398       include 'COMMON.VAR'
6399       include 'COMMON.GEO'
6400       logical swap
6401       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6402      & auxvec1(2),auxvec2(2),auxmat1(2,2)
6403       logical lprn
6404       common /kutas/ lprn
6405 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6406 C                                                                              C
6407 C      Parallel       Antiparallel                                             C
6408 C                                                                              C
6409 C          o             o                                                     C
6410 C     \   /l\           /j\   /                                                C
6411 C      \ /   \         /   \ /                                                 C
6412 C       o| o |         | o |o                                                  C
6413 C     \ j|/k\|      \  |/k\|l                                                  C
6414 C      \ /   \       \ /   \                                                   C
6415 C       o             o                                                        C
6416 C       i             i                                                        C
6417 C                                                                              C
6418 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6419 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6420 C AL 7/4/01 s1 would occur in the sixth-order moment,
6421 C           but not in a cluster cumulant
6422 #ifdef MOMENT
6423       s1=dip(1,jj,i)*dip(1,kk,k)
6424 #endif
6425       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
6426       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6427       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
6428       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
6429       call transpose2(EUg(1,1,k),auxmat(1,1))
6430       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
6431       vv(1)=pizda(1,1)-pizda(2,2)
6432       vv(2)=pizda(1,2)+pizda(2,1)
6433       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6434 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6435 #ifdef MOMENT
6436       eello6_graph2=-(s1+s2+s3+s4)
6437 #else
6438       eello6_graph2=-(s2+s3+s4)
6439 #endif
6440 c      eello6_graph2=-s3
6441       if (.not. calc_grad) return
6442 C Derivatives in gamma(i-1)
6443       if (i.gt.1) then
6444 #ifdef MOMENT
6445         s1=dipderg(1,jj,i)*dip(1,kk,k)
6446 #endif
6447         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6448         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
6449         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6450         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6451 #ifdef MOMENT
6452         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6453 #else
6454         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6455 #endif
6456 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
6457       endif
6458 C Derivatives in gamma(k-1)
6459 #ifdef MOMENT
6460       s1=dip(1,jj,i)*dipderg(1,kk,k)
6461 #endif
6462       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
6463       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6464       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
6465       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6466       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6467       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
6468       vv(1)=pizda(1,1)-pizda(2,2)
6469       vv(2)=pizda(1,2)+pizda(2,1)
6470       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6471 #ifdef MOMENT
6472       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6473 #else
6474       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6475 #endif
6476 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
6477 C Derivatives in gamma(j-1) or gamma(l-1)
6478       if (j.gt.1) then
6479 #ifdef MOMENT
6480         s1=dipderg(3,jj,i)*dip(1,kk,k)
6481 #endif
6482         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
6483         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6484         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
6485         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
6486         vv(1)=pizda(1,1)-pizda(2,2)
6487         vv(2)=pizda(1,2)+pizda(2,1)
6488         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6489 #ifdef MOMENT
6490         if (swap) then
6491           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6492         else
6493           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6494         endif
6495 #endif
6496         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
6497 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
6498       endif
6499 C Derivatives in gamma(l-1) or gamma(j-1)
6500       if (l.gt.1) then
6501 #ifdef MOMENT
6502         s1=dip(1,jj,i)*dipderg(3,kk,k)
6503 #endif
6504         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
6505         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6506         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
6507         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6508         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
6509         vv(1)=pizda(1,1)-pizda(2,2)
6510         vv(2)=pizda(1,2)+pizda(2,1)
6511         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6512 #ifdef MOMENT
6513         if (swap) then
6514           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6515         else
6516           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6517         endif
6518 #endif
6519         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
6520 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
6521       endif
6522 C Cartesian derivatives.
6523       if (lprn) then
6524         write (2,*) 'In eello6_graph2'
6525         do iii=1,2
6526           write (2,*) 'iii=',iii
6527           do kkk=1,5
6528             write (2,*) 'kkk=',kkk
6529             do jjj=1,2
6530               write (2,'(3(2f10.5),5x)')
6531      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6532             enddo
6533           enddo
6534         enddo
6535       endif
6536       do iii=1,2
6537         do kkk=1,5
6538           do lll=1,3
6539 #ifdef MOMENT
6540             if (iii.eq.1) then
6541               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
6542             else
6543               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
6544             endif
6545 #endif
6546             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
6547      &        auxvec(1))
6548             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6549             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
6550      &        auxvec(1))
6551             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
6552             call transpose2(EUg(1,1,k),auxmat(1,1))
6553             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
6554      &        pizda(1,1))
6555             vv(1)=pizda(1,1)-pizda(2,2)
6556             vv(2)=pizda(1,2)+pizda(2,1)
6557             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6558 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
6559 #ifdef MOMENT
6560             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6561 #else
6562             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6563 #endif
6564             if (swap) then
6565               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6566             else
6567               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6568             endif
6569           enddo
6570         enddo
6571       enddo
6572       return
6573       end
6574 c----------------------------------------------------------------------------
6575       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
6576       implicit real*8 (a-h,o-z)
6577       include 'DIMENSIONS'
6578       include 'sizesclu.dat'
6579       include 'COMMON.IOUNITS'
6580       include 'COMMON.CHAIN'
6581       include 'COMMON.DERIV'
6582       include 'COMMON.INTERACT'
6583       include 'COMMON.CONTACTS'
6584       include 'COMMON.TORSION'
6585       include 'COMMON.VAR'
6586       include 'COMMON.GEO'
6587       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
6588       logical swap
6589 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6590 C                                                                              C
6591 C      Parallel       Antiparallel                                             C
6592 C                                                                              C
6593 C          o             o                                                     C
6594 C         /l\   /   \   /j\                                                    C
6595 C        /   \ /     \ /   \                                                   C
6596 C       /| o |o       o| o |\                                                  C
6597 C       j|/k\|  /      |/k\|l /                                                C
6598 C        /   \ /       /   \ /                                                 C
6599 C       /     o       /     o                                                  C
6600 C       i             i                                                        C
6601 C                                                                              C
6602 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6603 C
6604 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6605 C           energy moment and not to the cluster cumulant.
6606       iti=itortyp(itype(i))
6607       if (j.lt.nres-1) then
6608         itj1=itortyp(itype(j+1))
6609       else
6610         itj1=ntortyp+1
6611       endif
6612       itk=itortyp(itype(k))
6613       itk1=itortyp(itype(k+1))
6614       if (l.lt.nres-1) then
6615         itl1=itortyp(itype(l+1))
6616       else
6617         itl1=ntortyp+1
6618       endif
6619 #ifdef MOMENT
6620       s1=dip(4,jj,i)*dip(4,kk,k)
6621 #endif
6622       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
6623       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6624       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
6625       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6626       call transpose2(EE(1,1,itk),auxmat(1,1))
6627       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
6628       vv(1)=pizda(1,1)+pizda(2,2)
6629       vv(2)=pizda(2,1)-pizda(1,2)
6630       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6631 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6632 #ifdef MOMENT
6633       eello6_graph3=-(s1+s2+s3+s4)
6634 #else
6635       eello6_graph3=-(s2+s3+s4)
6636 #endif
6637 c      eello6_graph3=-s4
6638       if (.not. calc_grad) return
6639 C Derivatives in gamma(k-1)
6640       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
6641       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6642       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
6643       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
6644 C Derivatives in gamma(l-1)
6645       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
6646       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6647       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
6648       vv(1)=pizda(1,1)+pizda(2,2)
6649       vv(2)=pizda(2,1)-pizda(1,2)
6650       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6651       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6652 C Cartesian derivatives.
6653       do iii=1,2
6654         do kkk=1,5
6655           do lll=1,3
6656 #ifdef MOMENT
6657             if (iii.eq.1) then
6658               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
6659             else
6660               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
6661             endif
6662 #endif
6663             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6664      &        auxvec(1))
6665             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6666             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6667      &        auxvec(1))
6668             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6669             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
6670      &        pizda(1,1))
6671             vv(1)=pizda(1,1)+pizda(2,2)
6672             vv(2)=pizda(2,1)-pizda(1,2)
6673             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6674 #ifdef MOMENT
6675             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6676 #else
6677             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6678 #endif
6679             if (swap) then
6680               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6681             else
6682               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6683             endif
6684 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
6685           enddo
6686         enddo
6687       enddo
6688       return
6689       end
6690 c----------------------------------------------------------------------------
6691       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
6692       implicit real*8 (a-h,o-z)
6693       include 'DIMENSIONS'
6694       include 'sizesclu.dat'
6695       include 'COMMON.IOUNITS'
6696       include 'COMMON.CHAIN'
6697       include 'COMMON.DERIV'
6698       include 'COMMON.INTERACT'
6699       include 'COMMON.CONTACTS'
6700       include 'COMMON.TORSION'
6701       include 'COMMON.VAR'
6702       include 'COMMON.GEO'
6703       include 'COMMON.FFIELD'
6704       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6705      & auxvec1(2),auxmat1(2,2)
6706       logical swap
6707 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6708 C                                                                              C
6709 C      Parallel       Antiparallel                                             C
6710 C                                                                              C
6711 C          o             o                                                     C
6712 C         /l\   /   \   /j\                                                    C
6713 C        /   \ /     \ /   \                                                   C
6714 C       /| o |o       o| o |\                                                  C
6715 C     \ j|/k\|      \  |/k\|l                                                  C
6716 C      \ /   \       \ /   \                                                   C
6717 C       o     \       o     \                                                  C
6718 C       i             i                                                        C
6719 C                                                                              C
6720 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6721 C
6722 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6723 C           energy moment and not to the cluster cumulant.
6724 cd      write (2,*) 'eello_graph4: wturn6',wturn6
6725       iti=itortyp(itype(i))
6726       itj=itortyp(itype(j))
6727       if (j.lt.nres-1) then
6728         itj1=itortyp(itype(j+1))
6729       else
6730         itj1=ntortyp+1
6731       endif
6732       itk=itortyp(itype(k))
6733       if (k.lt.nres-1) then
6734         itk1=itortyp(itype(k+1))
6735       else
6736         itk1=ntortyp+1
6737       endif
6738       itl=itortyp(itype(l))
6739       if (l.lt.nres-1) then
6740         itl1=itortyp(itype(l+1))
6741       else
6742         itl1=ntortyp+1
6743       endif
6744 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
6745 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
6746 cd     & ' itl',itl,' itl1',itl1
6747 #ifdef MOMENT
6748       if (imat.eq.1) then
6749         s1=dip(3,jj,i)*dip(3,kk,k)
6750       else
6751         s1=dip(2,jj,j)*dip(2,kk,l)
6752       endif
6753 #endif
6754       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
6755       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6756       if (j.eq.l+1) then
6757         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
6758         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6759       else
6760         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
6761         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6762       endif
6763       call transpose2(EUg(1,1,k),auxmat(1,1))
6764       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
6765       vv(1)=pizda(1,1)-pizda(2,2)
6766       vv(2)=pizda(2,1)+pizda(1,2)
6767       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6768 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6769 #ifdef MOMENT
6770       eello6_graph4=-(s1+s2+s3+s4)
6771 #else
6772       eello6_graph4=-(s2+s3+s4)
6773 #endif
6774       if (.not. calc_grad) return
6775 C Derivatives in gamma(i-1)
6776       if (i.gt.1) then
6777 #ifdef MOMENT
6778         if (imat.eq.1) then
6779           s1=dipderg(2,jj,i)*dip(3,kk,k)
6780         else
6781           s1=dipderg(4,jj,j)*dip(2,kk,l)
6782         endif
6783 #endif
6784         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6785         if (j.eq.l+1) then
6786           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
6787           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6788         else
6789           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
6790           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6791         endif
6792         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6793         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6794 cd          write (2,*) 'turn6 derivatives'
6795 #ifdef MOMENT
6796           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
6797 #else
6798           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
6799 #endif
6800         else
6801 #ifdef MOMENT
6802           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6803 #else
6804           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6805 #endif
6806         endif
6807       endif
6808 C Derivatives in gamma(k-1)
6809 #ifdef MOMENT
6810       if (imat.eq.1) then
6811         s1=dip(3,jj,i)*dipderg(2,kk,k)
6812       else
6813         s1=dip(2,jj,j)*dipderg(4,kk,l)
6814       endif
6815 #endif
6816       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
6817       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
6818       if (j.eq.l+1) then
6819         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
6820         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6821       else
6822         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
6823         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6824       endif
6825       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6826       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
6827       vv(1)=pizda(1,1)-pizda(2,2)
6828       vv(2)=pizda(2,1)+pizda(1,2)
6829       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6830       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6831 #ifdef MOMENT
6832         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
6833 #else
6834         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
6835 #endif
6836       else
6837 #ifdef MOMENT
6838         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6839 #else
6840         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6841 #endif
6842       endif
6843 C Derivatives in gamma(j-1) or gamma(l-1)
6844       if (l.eq.j+1 .and. l.gt.1) then
6845         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
6846         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6847         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
6848         vv(1)=pizda(1,1)-pizda(2,2)
6849         vv(2)=pizda(2,1)+pizda(1,2)
6850         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6851         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6852       else if (j.gt.1) then
6853         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
6854         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6855         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
6856         vv(1)=pizda(1,1)-pizda(2,2)
6857         vv(2)=pizda(2,1)+pizda(1,2)
6858         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6859         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6860           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
6861         else
6862           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
6863         endif
6864       endif
6865 C Cartesian derivatives.
6866       do iii=1,2
6867         do kkk=1,5
6868           do lll=1,3
6869 #ifdef MOMENT
6870             if (iii.eq.1) then
6871               if (imat.eq.1) then
6872                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
6873               else
6874                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
6875               endif
6876             else
6877               if (imat.eq.1) then
6878                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
6879               else
6880                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
6881               endif
6882             endif
6883 #endif
6884             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
6885      &        auxvec(1))
6886             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6887             if (j.eq.l+1) then
6888               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
6889      &          b1(1,itj1),auxvec(1))
6890               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
6891             else
6892               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
6893      &          b1(1,itl1),auxvec(1))
6894               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
6895             endif
6896             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6897      &        pizda(1,1))
6898             vv(1)=pizda(1,1)-pizda(2,2)
6899             vv(2)=pizda(2,1)+pizda(1,2)
6900             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6901             if (swap) then
6902               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6903 #ifdef MOMENT
6904                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
6905      &             -(s1+s2+s4)
6906 #else
6907                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
6908      &             -(s2+s4)
6909 #endif
6910                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
6911               else
6912 #ifdef MOMENT
6913                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
6914 #else
6915                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
6916 #endif
6917                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6918               endif
6919             else
6920 #ifdef MOMENT
6921               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6922 #else
6923               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6924 #endif
6925               if (l.eq.j+1) then
6926                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6927               else
6928                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6929               endif
6930             endif
6931           enddo
6932         enddo
6933       enddo
6934       return
6935       end
6936 c----------------------------------------------------------------------------
6937       double precision function eello_turn6(i,jj,kk)
6938       implicit real*8 (a-h,o-z)
6939       include 'DIMENSIONS'
6940       include 'sizesclu.dat'
6941       include 'COMMON.IOUNITS'
6942       include 'COMMON.CHAIN'
6943       include 'COMMON.DERIV'
6944       include 'COMMON.INTERACT'
6945       include 'COMMON.CONTACTS'
6946       include 'COMMON.TORSION'
6947       include 'COMMON.VAR'
6948       include 'COMMON.GEO'
6949       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
6950      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
6951      &  ggg1(3),ggg2(3)
6952       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
6953      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
6954 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
6955 C           the respective energy moment and not to the cluster cumulant.
6956       eello_turn6=0.0d0
6957       j=i+4
6958       k=i+1
6959       l=i+3
6960       iti=itortyp(itype(i))
6961       itk=itortyp(itype(k))
6962       itk1=itortyp(itype(k+1))
6963       itl=itortyp(itype(l))
6964       itj=itortyp(itype(j))
6965 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
6966 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
6967 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6968 cd        eello6=0.0d0
6969 cd        return
6970 cd      endif
6971 cd      write (iout,*)
6972 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6973 cd     &   ' and',k,l
6974 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
6975       do iii=1,2
6976         do kkk=1,5
6977           do lll=1,3
6978             derx_turn(lll,kkk,iii)=0.0d0
6979           enddo
6980         enddo
6981       enddo
6982 cd      eij=1.0d0
6983 cd      ekl=1.0d0
6984 cd      ekont=1.0d0
6985       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6986 cd      eello6_5=0.0d0
6987 cd      write (2,*) 'eello6_5',eello6_5
6988 #ifdef MOMENT
6989       call transpose2(AEA(1,1,1),auxmat(1,1))
6990       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
6991       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
6992       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
6993 #else
6994       s1 = 0.0d0
6995 #endif
6996       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
6997       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
6998       s2 = scalar2(b1(1,itk),vtemp1(1))
6999 #ifdef MOMENT
7000       call transpose2(AEA(1,1,2),atemp(1,1))
7001       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7002       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7003       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7004 #else
7005       s8=0.0d0
7006 #endif
7007       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7008       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7009       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7010 #ifdef MOMENT
7011       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7012       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7013       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7014       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7015       ss13 = scalar2(b1(1,itk),vtemp4(1))
7016       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7017 #else
7018       s13=0.0d0
7019 #endif
7020 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7021 c      s1=0.0d0
7022 c      s2=0.0d0
7023 c      s8=0.0d0
7024 c      s12=0.0d0
7025 c      s13=0.0d0
7026       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7027       if (calc_grad) then
7028 C Derivatives in gamma(i+2)
7029 #ifdef MOMENT
7030       call transpose2(AEA(1,1,1),auxmatd(1,1))
7031       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7032       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7033       call transpose2(AEAderg(1,1,2),atempd(1,1))
7034       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7035       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7036 #else
7037       s8d=0.0d0
7038 #endif
7039       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7040       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7041       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7042 c      s1d=0.0d0
7043 c      s2d=0.0d0
7044 c      s8d=0.0d0
7045 c      s12d=0.0d0
7046 c      s13d=0.0d0
7047       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7048 C Derivatives in gamma(i+3)
7049 #ifdef MOMENT
7050       call transpose2(AEA(1,1,1),auxmatd(1,1))
7051       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7052       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7053       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7054 #else
7055       s1d=0.0d0
7056 #endif
7057       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7058       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7059       s2d = scalar2(b1(1,itk),vtemp1d(1))
7060 #ifdef MOMENT
7061       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7062       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7063 #endif
7064       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7065 #ifdef MOMENT
7066       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7067       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7068       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7069 #else
7070       s13d=0.0d0
7071 #endif
7072 c      s1d=0.0d0
7073 c      s2d=0.0d0
7074 c      s8d=0.0d0
7075 c      s12d=0.0d0
7076 c      s13d=0.0d0
7077 #ifdef MOMENT
7078       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7079      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7080 #else
7081       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7082      &               -0.5d0*ekont*(s2d+s12d)
7083 #endif
7084 C Derivatives in gamma(i+4)
7085       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7086       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7087       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7088 #ifdef MOMENT
7089       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7090       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7091       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7092 #else
7093       s13d = 0.0d0
7094 #endif
7095 c      s1d=0.0d0
7096 c      s2d=0.0d0
7097 c      s8d=0.0d0
7098 C      s12d=0.0d0
7099 c      s13d=0.0d0
7100 #ifdef MOMENT
7101       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7102 #else
7103       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7104 #endif
7105 C Derivatives in gamma(i+5)
7106 #ifdef MOMENT
7107       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7108       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7109       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7110 #else
7111       s1d = 0.0d0
7112 #endif
7113       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7114       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7115       s2d = scalar2(b1(1,itk),vtemp1d(1))
7116 #ifdef MOMENT
7117       call transpose2(AEA(1,1,2),atempd(1,1))
7118       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7119       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7120 #else
7121       s8d = 0.0d0
7122 #endif
7123       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7124       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7125 #ifdef MOMENT
7126       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7127       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7128       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7129 #else
7130       s13d = 0.0d0
7131 #endif
7132 c      s1d=0.0d0
7133 c      s2d=0.0d0
7134 c      s8d=0.0d0
7135 c      s12d=0.0d0
7136 c      s13d=0.0d0
7137 #ifdef MOMENT
7138       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7139      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7140 #else
7141       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7142      &               -0.5d0*ekont*(s2d+s12d)
7143 #endif
7144 C Cartesian derivatives
7145       do iii=1,2
7146         do kkk=1,5
7147           do lll=1,3
7148 #ifdef MOMENT
7149             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7150             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7151             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7152 #else
7153             s1d = 0.0d0
7154 #endif
7155             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7156             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7157      &          vtemp1d(1))
7158             s2d = scalar2(b1(1,itk),vtemp1d(1))
7159 #ifdef MOMENT
7160             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7161             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7162             s8d = -(atempd(1,1)+atempd(2,2))*
7163      &           scalar2(cc(1,1,itl),vtemp2(1))
7164 #else
7165             s8d = 0.0d0
7166 #endif
7167             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7168      &           auxmatd(1,1))
7169             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7170             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7171 c      s1d=0.0d0
7172 c      s2d=0.0d0
7173 c      s8d=0.0d0
7174 c      s12d=0.0d0
7175 c      s13d=0.0d0
7176 #ifdef MOMENT
7177             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7178      &        - 0.5d0*(s1d+s2d)
7179 #else
7180             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7181      &        - 0.5d0*s2d
7182 #endif
7183 #ifdef MOMENT
7184             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7185      &        - 0.5d0*(s8d+s12d)
7186 #else
7187             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7188      &        - 0.5d0*s12d
7189 #endif
7190           enddo
7191         enddo
7192       enddo
7193 #ifdef MOMENT
7194       do kkk=1,5
7195         do lll=1,3
7196           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7197      &      achuj_tempd(1,1))
7198           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7199           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7200           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7201           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7202           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7203      &      vtemp4d(1))
7204           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7205           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7206           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7207         enddo
7208       enddo
7209 #endif
7210 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7211 cd     &  16*eel_turn6_num
7212 cd      goto 1112
7213       if (j.lt.nres-1) then
7214         j1=j+1
7215         j2=j-1
7216       else
7217         j1=j-1
7218         j2=j-2
7219       endif
7220       if (l.lt.nres-1) then
7221         l1=l+1
7222         l2=l-1
7223       else
7224         l1=l-1
7225         l2=l-2
7226       endif
7227       do ll=1,3
7228         ggg1(ll)=eel_turn6*g_contij(ll,1)
7229         ggg2(ll)=eel_turn6*g_contij(ll,2)
7230         ghalf=0.5d0*ggg1(ll)
7231 cd        ghalf=0.0d0
7232         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7233      &    +ekont*derx_turn(ll,2,1)
7234         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7235         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7236      &    +ekont*derx_turn(ll,4,1)
7237         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7238         ghalf=0.5d0*ggg2(ll)
7239 cd        ghalf=0.0d0
7240         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7241      &    +ekont*derx_turn(ll,2,2)
7242         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7243         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7244      &    +ekont*derx_turn(ll,4,2)
7245         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7246       enddo
7247 cd      goto 1112
7248       do m=i+1,j-1
7249         do ll=1,3
7250           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7251         enddo
7252       enddo
7253       do m=k+1,l-1
7254         do ll=1,3
7255           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7256         enddo
7257       enddo
7258 1112  continue
7259       do m=i+2,j2
7260         do ll=1,3
7261           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7262         enddo
7263       enddo
7264       do m=k+2,l2
7265         do ll=1,3
7266           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7267         enddo
7268       enddo
7269 cd      do iii=1,nres-3
7270 cd        write (2,*) iii,g_corr6_loc(iii)
7271 cd      enddo
7272       endif
7273       eello_turn6=ekont*eel_turn6
7274 cd      write (2,*) 'ekont',ekont
7275 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7276       return
7277       end
7278 crc-------------------------------------------------
7279       SUBROUTINE MATVEC2(A1,V1,V2)
7280       implicit real*8 (a-h,o-z)
7281       include 'DIMENSIONS'
7282       DIMENSION A1(2,2),V1(2),V2(2)
7283 c      DO 1 I=1,2
7284 c        VI=0.0
7285 c        DO 3 K=1,2
7286 c    3     VI=VI+A1(I,K)*V1(K)
7287 c        Vaux(I)=VI
7288 c    1 CONTINUE
7289
7290       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7291       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7292
7293       v2(1)=vaux1
7294       v2(2)=vaux2
7295       END
7296 C---------------------------------------
7297       SUBROUTINE MATMAT2(A1,A2,A3)
7298       implicit real*8 (a-h,o-z)
7299       include 'DIMENSIONS'
7300       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7301 c      DIMENSION AI3(2,2)
7302 c        DO  J=1,2
7303 c          A3IJ=0.0
7304 c          DO K=1,2
7305 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7306 c          enddo
7307 c          A3(I,J)=A3IJ
7308 c       enddo
7309 c      enddo
7310
7311       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7312       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7313       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7314       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7315
7316       A3(1,1)=AI3_11
7317       A3(2,1)=AI3_21
7318       A3(1,2)=AI3_12
7319       A3(2,2)=AI3_22
7320       END
7321
7322 c-------------------------------------------------------------------------
7323       double precision function scalar2(u,v)
7324       implicit none
7325       double precision u(2),v(2)
7326       double precision sc
7327       integer i
7328       scalar2=u(1)*v(1)+u(2)*v(2)
7329       return
7330       end
7331
7332 C-----------------------------------------------------------------------------
7333
7334       subroutine transpose2(a,at)
7335       implicit none
7336       double precision a(2,2),at(2,2)
7337       at(1,1)=a(1,1)
7338       at(1,2)=a(2,1)
7339       at(2,1)=a(1,2)
7340       at(2,2)=a(2,2)
7341       return
7342       end
7343 c--------------------------------------------------------------------------
7344       subroutine transpose(n,a,at)
7345       implicit none
7346       integer n,i,j
7347       double precision a(n,n),at(n,n)
7348       do i=1,n
7349         do j=1,n
7350           at(j,i)=a(i,j)
7351         enddo
7352       enddo
7353       return
7354       end
7355 C---------------------------------------------------------------------------
7356       subroutine prodmat3(a1,a2,kk,transp,prod)
7357       implicit none
7358       integer i,j
7359       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
7360       logical transp
7361 crc      double precision auxmat(2,2),prod_(2,2)
7362
7363       if (transp) then
7364 crc        call transpose2(kk(1,1),auxmat(1,1))
7365 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
7366 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7367
7368            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
7369      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
7370            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
7371      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
7372            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
7373      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
7374            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
7375      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
7376
7377       else
7378 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
7379 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7380
7381            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
7382      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
7383            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
7384      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
7385            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
7386      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
7387            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
7388      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
7389
7390       endif
7391 c      call transpose2(a2(1,1),a2t(1,1))
7392
7393 crc      print *,transp
7394 crc      print *,((prod_(i,j),i=1,2),j=1,2)
7395 crc      print *,((prod(i,j),i=1,2),j=1,2)
7396
7397       return
7398       end
7399 C-----------------------------------------------------------------------------
7400       double precision function scalar(u,v)
7401       implicit none
7402       double precision u(3),v(3)
7403       double precision sc
7404       integer i
7405       sc=0.0d0
7406       do i=1,3
7407         sc=sc+u(i)*v(i)
7408       enddo
7409       scalar=sc
7410       return
7411       end
7412