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