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