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