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