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