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