source/cluster/wham/src/energy_p_new.F

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