subroutine etotal(energia,fact)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'

#ifndef ISNAN
      external proc_proc
#endif
#ifdef WINPGI
cMS$ATTRIBUTES C ::  proc_proc
#endif

      include 'COMMON.IOUNITS'
      double precision energia(0:max_ene),energia1(0:max_ene+1)
#ifdef MPL
      include 'COMMON.INFO'
      external d_vadd
      integer ready
#endif
      include 'COMMON.FFIELD'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.SBRIDGE'
      include 'COMMON.CHAIN'
      include 'COMMON.SHIELD'
      include 'COMMON.CONTROL'
      double precision fact(6)
cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
cd    print *,'nnt=',nnt,' nct=',nct
C
C Compute the side-chain and electrostatic interaction energy
C
      goto (101,102,103,104,105) ipot
C Lennard-Jones potential.
  101 call elj(evdw,evdw_t)
cd    print '(a)','Exit ELJ'
      goto 106
C Lennard-Jones-Kihara potential (shifted).
  102 call eljk(evdw,evdw_t)
      goto 106
C Berne-Pechukas potential (dilated LJ, angular dependence).
  103 call ebp(evdw,evdw_t)
      goto 106
C Gay-Berne potential (shifted LJ, angular dependence).
  104 call egb(evdw,evdw_t)
      goto 106
C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  105 call egbv(evdw,evdw_t)
C
C Calculate electrostatic (H-bonding) energy of the main chain.
C
  106 continue
C      write(iout,*) "shield_mode",shield_mode,ethetacnstr 
      if (shield_mode.eq.1) then
       call set_shield_fac
      else if  (shield_mode.eq.2) then
       call set_shield_fac2
      endif
      call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
C
C Calculate excluded-volume interaction energy between peptide groups
C and side chains.
C
      call escp(evdw2,evdw2_14)
c
c Calculate the bond-stretching energy
c
      call ebond(estr)
c      write (iout,*) "estr",estr
C 
C Calculate the disulfide-bridge and other energy and the contributions
C from other distance constraints.
cd    print *,'Calling EHPB'
      call edis(ehpb)
cd    print *,'EHPB exitted succesfully.'
C
C Calculate the virtual-bond-angle energy.
C
      call ebend(ebe,ethetacnstr)
cd    print *,'Bend energy finished.'
C
C Calculate the SC local energy.
C
      call esc(escloc)
cd    print *,'SCLOC energy finished.'
C
C Calculate the virtual-bond torsional energy.
C
cd    print *,'nterm=',nterm
      call etor(etors,edihcnstr,fact(1))
C
C 6/23/01 Calculate double-torsional energy
C
      call etor_d(etors_d,fact(2))
C
C 21/5/07 Calculate local sicdechain correlation energy
C
      call eback_sc_corr(esccor)

      if (wliptran.gt.0) then
        call Eliptransfer(eliptran)
      endif

C 
C 12/1/95 Multi-body terms
C
      n_corr=0
      n_corr1=0
      if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 
     &    .or. wturn6.gt.0.0d0) then
c         print *,"calling multibody_eello"
         call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
c         print *,ecorr,ecorr5,ecorr6,eturn6
      else
         ecorr=0.0d0
         ecorr5=0.0d0
         ecorr6=0.0d0
         eturn6=0.0d0
      endif
      if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
         call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
      endif

c      write(iout,*) "TEST_ENE",constr_homology
      if (constr_homology.ge.1) then
        call e_modeller(ehomology_constr)
      else
        ehomology_constr=0.0d0
      endif
c      write(iout,*) "TEST_ENE",ehomology_constr


      write (iout,*) "ft(6)",fact(6),wliptran,eliptran
#ifdef SPLITELE
      if (shield_mode.gt.0) then
      etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
     & +welec*fact(1)*ees
     & +fact(1)*wvdwpp*evdw1
     & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
     & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
     & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
     & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
     & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
     & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
     & +wliptran*eliptran
      else
      etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
     & +wvdwpp*evdw1
     & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
     & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
     & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
     & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
     & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
     & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
     & +wliptran*eliptran
      endif
#else
      if (shield_mode.gt.0) then
      etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
     & +welec*fact(1)*(ees+evdw1)
     & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
     & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
     & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
     & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
     & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
     & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
     & +wliptran*eliptran
      else
      etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
     & +welec*fact(1)*(ees+evdw1)
     & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
     & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
     & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
     & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
     & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
     & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
     & +wliptran*eliptran
      endif
#endif

      energia(0)=etot
      energia(1)=evdw
#ifdef SCP14
      energia(2)=evdw2-evdw2_14
      energia(17)=evdw2_14
#else
      energia(2)=evdw2
      energia(17)=0.0d0
#endif
#ifdef SPLITELE
      energia(3)=ees
      energia(16)=evdw1
#else
      energia(3)=ees+evdw1
      energia(16)=0.0d0
#endif
      energia(4)=ecorr
      energia(5)=ecorr5
      energia(6)=ecorr6
      energia(7)=eel_loc
      energia(8)=eello_turn3
      energia(9)=eello_turn4
      energia(10)=eturn6
      energia(11)=ebe
      energia(12)=escloc
      energia(13)=etors
      energia(14)=etors_d
      energia(15)=ehpb
      energia(18)=estr
      energia(19)=esccor
      energia(20)=edihcnstr
      energia(24)=ehomology_constr
      energia(21)=evdw_t
c      energia(24)=ethetacnstr
      energia(22)=eliptran
c detecting NaNQ
#ifdef ISNAN
#ifdef AIX
      if (isnan(etot).ne.0) energia(0)=1.0d+99
#else
      if (isnan(etot)) energia(0)=1.0d+99
#endif
#else
      i=0
#ifdef WINPGI
      idumm=proc_proc(etot,i)
#else
      call proc_proc(etot,i)
#endif
      if(i.eq.1)energia(0)=1.0d+99
#endif
#ifdef MPL
c     endif
#endif
      if (calc_grad) then
C
C Sum up the components of the Cartesian gradient.
C
#ifdef SPLITELE
      do i=1,nct
        do j=1,3
      if (shield_mode.eq.0) then
          gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
     &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
     &                wbond*gradb(j,i)+
     &                wstrain*ghpbc(j,i)+
     &                wcorr*fact(3)*gradcorr(j,i)+
     &                wel_loc*fact(2)*gel_loc(j,i)+
     &                wturn3*fact(2)*gcorr3_turn(j,i)+
     &                wturn4*fact(3)*gcorr4_turn(j,i)+
     &                wcorr5*fact(4)*gradcorr5(j,i)+
     &                wcorr6*fact(5)*gradcorr6(j,i)+
     &                wturn6*fact(5)*gcorr6_turn(j,i)+
     &                wsccor*fact(2)*gsccorc(j,i)
     &               +wliptran*gliptranc(j,i)
          gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
     &                  wbond*gradbx(j,i)+
     &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
     &                  wsccor*fact(2)*gsccorx(j,i)
     &                 +wliptran*gliptranx(j,i)
        else
          gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
     &                +fact(1)*wscp*gvdwc_scp(j,i)+
     &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
     &                wbond*gradb(j,i)+
     &                wstrain*ghpbc(j,i)+
     &                wcorr*fact(3)*gradcorr(j,i)+
     &                wel_loc*fact(2)*gel_loc(j,i)+
     &                wturn3*fact(2)*gcorr3_turn(j,i)+
     &                wturn4*fact(3)*gcorr4_turn(j,i)+
     &                wcorr5*fact(4)*gradcorr5(j,i)+
     &                wcorr6*fact(5)*gradcorr6(j,i)+
     &                wturn6*fact(5)*gcorr6_turn(j,i)+
     &                wsccor*fact(2)*gsccorc(j,i)
     &               +wliptran*gliptranc(j,i)
     &                 +welec*gshieldc(j,i)
     &                 +welec*gshieldc_loc(j,i)
     &                 +wcorr*gshieldc_ec(j,i)
     &                 +wcorr*gshieldc_loc_ec(j,i)
     &                 +wturn3*gshieldc_t3(j,i)
     &                 +wturn3*gshieldc_loc_t3(j,i)
     &                 +wturn4*gshieldc_t4(j,i)
     &                 +wturn4*gshieldc_loc_t4(j,i)
     &                 +wel_loc*gshieldc_ll(j,i)
     &                 +wel_loc*gshieldc_loc_ll(j,i)

          gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
     &                 +fact(1)*wscp*gradx_scp(j,i)+
     &                  wbond*gradbx(j,i)+
     &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
     &                  wsccor*fact(2)*gsccorx(j,i)
     &                 +wliptran*gliptranx(j,i)
     &                 +welec*gshieldx(j,i)
     &                 +wcorr*gshieldx_ec(j,i)
     &                 +wturn3*gshieldx_t3(j,i)
     &                 +wturn4*gshieldx_t4(j,i)
     &                 +wel_loc*gshieldx_ll(j,i)


        endif
        enddo
#else
       do i=1,nct
        do j=1,3
                if (shield_mode.eq.0) then
          gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
     &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
     &                wbond*gradb(j,i)+
     &                wcorr*fact(3)*gradcorr(j,i)+
     &                wel_loc*fact(2)*gel_loc(j,i)+
     &                wturn3*fact(2)*gcorr3_turn(j,i)+
     &                wturn4*fact(3)*gcorr4_turn(j,i)+
     &                wcorr5*fact(4)*gradcorr5(j,i)+
     &                wcorr6*fact(5)*gradcorr6(j,i)+
     &                wturn6*fact(5)*gcorr6_turn(j,i)+
     &                wsccor*fact(2)*gsccorc(j,i)
     &               +wliptran*gliptranc(j,i)
          gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
     &                  wbond*gradbx(j,i)+
     &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
     &                  wsccor*fact(1)*gsccorx(j,i)
     &                 +wliptran*gliptranx(j,i)
              else
          gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
     &                   fact(1)*wscp*gvdwc_scp(j,i)+
     &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
     &                wbond*gradb(j,i)+
     &                wcorr*fact(3)*gradcorr(j,i)+
     &                wel_loc*fact(2)*gel_loc(j,i)+
     &                wturn3*fact(2)*gcorr3_turn(j,i)+
     &                wturn4*fact(3)*gcorr4_turn(j,i)+
     &                wcorr5*fact(4)*gradcorr5(j,i)+
     &                wcorr6*fact(5)*gradcorr6(j,i)+
     &                wturn6*fact(5)*gcorr6_turn(j,i)+
     &                wsccor*fact(2)*gsccorc(j,i)
     &               +wliptran*gliptranc(j,i)
          gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
     &                  fact(1)*wscp*gradx_scp(j,i)+
     &                  wbond*gradbx(j,i)+
     &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
     &                  wsccor*fact(1)*gsccorx(j,i)
     &                 +wliptran*gliptranx(j,i)
         endif
        enddo     
#endif
      enddo


      do i=1,nres-3
        gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
     &   +wcorr5*fact(4)*g_corr5_loc(i)
     &   +wcorr6*fact(5)*g_corr6_loc(i)
     &   +wturn4*fact(3)*gel_loc_turn4(i)
     &   +wturn3*fact(2)*gel_loc_turn3(i)
     &   +wturn6*fact(5)*gel_loc_turn6(i)
     &   +wel_loc*fact(2)*gel_loc_loc(i)
c     &   +wsccor*fact(1)*gsccor_loc(i)
c ROZNICA Z WHAMem
      enddo
      endif
      if (dyn_ss) call dyn_set_nss
      return
      end
C------------------------------------------------------------------------
      subroutine enerprint(energia,fact)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.FFIELD'
      include 'COMMON.SBRIDGE'
      double precision energia(0:max_ene),fact(6)
      etot=energia(0)
      evdw=energia(1)+fact(6)*energia(21)
#ifdef SCP14
      evdw2=energia(2)+energia(17)
#else
      evdw2=energia(2)
#endif
      ees=energia(3)
#ifdef SPLITELE
      evdw1=energia(16)
#endif
      ecorr=energia(4)
      ecorr5=energia(5)
      ecorr6=energia(6)
      eel_loc=energia(7)
      eello_turn3=energia(8)
      eello_turn4=energia(9)
      eello_turn6=energia(10)
      ebe=energia(11)
      escloc=energia(12)
      etors=energia(13)
      etors_d=energia(14)
      ehpb=energia(15)
      esccor=energia(19)
      edihcnstr=energia(20)
      estr=energia(18)
      ehomology_constr=energia(24)
c      ethetacnstr=energia(24)
#ifdef SPLITELE
      write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
     &  wvdwpp,
     &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
     &  etors_d,wtor_d*fact(2),ehpb,wstrain,
     &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
     &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
     &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
     &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
     &  etot
   10 format (/'Virtual-chain energies:'//
     & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
     & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
     & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
     & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
     & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
     & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
     & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
     & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
     & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
     & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
     & ' (SS bridges & dist. cnstr.)'/
     & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
     & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
     & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
     & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
     & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
     & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
     & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
     & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
     & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
     & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
     & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ 
     & 'ETOT=  ',1pE16.6,' (total)')
#else
      write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
     &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
     &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
     &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
     &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
     &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
     &  edihcnstr,ehomology_constr,ebr*nss,
     &  etot
   10 format (/'Virtual-chain energies:'//
     & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
     & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
     & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
     & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
     & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
     & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
     & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
     & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
     & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
     & ' (SS bridges & dist. cnstr.)'/
     & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
     & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
     & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
     & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
     & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
     & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
     & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
     & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
     & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
     & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
     & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ 
     & 'ETOT=  ',1pE16.6,' (total)')
#endif
      return
      end
C-----------------------------------------------------------------------
      subroutine elj(evdw,evdw_t)
C
C This subroutine calculates the interaction energy of nonbonded side chains
C assuming the LJ potential of interaction.
C
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include "DIMENSIONS.COMPAR"
      parameter (accur=1.0d-10)
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.TORSION'
      include 'COMMON.SBRIDGE'
      include 'COMMON.NAMES'
      include 'COMMON.IOUNITS'
      include 'COMMON.CONTACTS'
      dimension gg(3)
      integer icant
      external icant
cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
c ROZNICA DODANE Z WHAM
c      do i=1,210
c        do j=1,2
c          eneps_temp(j,i)=0.0d0
c        enddo
c      enddo
cROZNICA

      evdw=0.0D0
      evdw_t=0.0d0
      do i=iatsc_s,iatsc_e
        itypi=iabs(itype(i))
        if (itypi.eq.ntyp1) cycle
        itypi1=iabs(itype(i+1))
        xi=c(1,nres+i)
        yi=c(2,nres+i)
        zi=c(3,nres+i)
C Change 12/1/95
        num_conti=0
C
C Calculate SC interaction energy.
C
        do iint=1,nint_gr(i)
cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
cd   &                  'iend=',iend(i,iint)
          do j=istart(i,iint),iend(i,iint)
            itypj=iabs(itype(j))
            if (itypj.eq.ntyp1) cycle
            xj=c(1,nres+j)-xi
            yj=c(2,nres+j)-yi
            zj=c(3,nres+j)-zi
C Change 12/1/95 to calculate four-body interactions
            rij=xj*xj+yj*yj+zj*zj
            rrij=1.0D0/rij
c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
            eps0ij=eps(itypi,itypj)
            fac=rrij**expon2
            e1=fac*fac*aa
            e2=fac*bb
            evdwij=e1+e2
            ij=icant(itypi,itypj)
c ROZNICA z WHAM
c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
c

cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
            if (bb.gt.0.0d0) then
              evdw=evdw+evdwij
            else
              evdw_t=evdw_t+evdwij
            endif
            if (calc_grad) then
C 
C Calculate the components of the gradient in DC and X
C
            fac=-rrij*(e1+evdwij)
            gg(1)=xj*fac
            gg(2)=yj*fac
            gg(3)=zj*fac
            do k=1,3
              gvdwx(k,i)=gvdwx(k,i)-gg(k)
              gvdwx(k,j)=gvdwx(k,j)+gg(k)
            enddo
            do k=i,j-1
              do l=1,3
                gvdwc(l,k)=gvdwc(l,k)+gg(l)
              enddo
            enddo
            endif
C
C 12/1/95, revised on 5/20/97
C
C Calculate the contact function. The ith column of the array JCONT will 
C contain the numbers of atoms that make contacts with the atom I (of numbers
C greater than I). The arrays FACONT and GACONT will contain the values of
C the contact function and its derivative.
C
C Uncomment next line, if the correlation interactions include EVDW explicitly.
c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
C Uncomment next line, if the correlation interactions are contact function only
            if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
              rij=dsqrt(rij)
              sigij=sigma(itypi,itypj)
              r0ij=rs0(itypi,itypj)
C
C Check whether the SC's are not too far to make a contact.
C
              rcut=1.5d0*r0ij
              call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
C
              if (fcont.gt.0.0D0) then
C If the SC-SC distance if close to sigma, apply spline.
cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
cAdam &             fcont1,fprimcont1)
cAdam           fcont1=1.0d0-fcont1
cAdam           if (fcont1.gt.0.0d0) then
cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
cAdam             fcont=fcont*fcont1
cAdam           endif
C Uncomment following 4 lines to have the geometric average of the epsilon0's
cga             eps0ij=1.0d0/dsqrt(eps0ij)
cga             do k=1,3
cga               gg(k)=gg(k)*eps0ij
cga             enddo
cga             eps0ij=-evdwij*eps0ij
C Uncomment for AL's type of SC correlation interactions.
cadam           eps0ij=-evdwij
                num_conti=num_conti+1
                jcont(num_conti,i)=j
                facont(num_conti,i)=fcont*eps0ij
                fprimcont=eps0ij*fprimcont/rij
                fcont=expon*fcont
cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
C Uncomment following 3 lines for Skolnick's type of SC correlation.
                gacont(1,num_conti,i)=-fprimcont*xj
                gacont(2,num_conti,i)=-fprimcont*yj
                gacont(3,num_conti,i)=-fprimcont*zj
cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
cd              write (iout,'(2i3,3f10.5)') 
cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
              endif
            endif
          enddo      ! j
        enddo        ! iint
C Change 12/1/95
        num_cont(i)=num_conti
      enddo          ! i
      if (calc_grad) then
      do i=1,nct
        do j=1,3
          gvdwc(j,i)=expon*gvdwc(j,i)
          gvdwx(j,i)=expon*gvdwx(j,i)
        enddo
      enddo
      endif
C******************************************************************************
C
C                              N O T E !!!
C
C To save time, the factor of EXPON has been extracted from ALL components
C of GVDWC and GRADX. Remember to multiply them by this factor before further 
C use!
C
C******************************************************************************
      return
      end
C-----------------------------------------------------------------------------
      subroutine eljk(evdw,evdw_t)
C
C This subroutine calculates the interaction energy of nonbonded side chains
C assuming the LJK potential of interaction.
C
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include "DIMENSIONS.COMPAR"
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.IOUNITS'
      include 'COMMON.NAMES'
      dimension gg(3)
      logical scheck
      integer icant
      external icant
c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
      evdw=0.0D0
      evdw_t=0.0d0
      do i=iatsc_s,iatsc_e
        itypi=iabs(itype(i))
        if (itypi.eq.ntyp1) cycle
        itypi1=iabs(itype(i+1))
        xi=c(1,nres+i)
        yi=c(2,nres+i)
        zi=c(3,nres+i)
C
C Calculate SC interaction energy.
C
        do iint=1,nint_gr(i)
          do j=istart(i,iint),iend(i,iint)
            itypj=iabs(itype(j))
            if (itypj.eq.ntyp1) cycle
            xj=c(1,nres+j)-xi
            yj=c(2,nres+j)-yi
            zj=c(3,nres+j)-zi
            rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
            fac_augm=rrij**expon
            e_augm=augm(itypi,itypj)*fac_augm
            r_inv_ij=dsqrt(rrij)
            rij=1.0D0/r_inv_ij 
            r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
            fac=r_shift_inv**expon
            e1=fac*fac*aa
            e2=fac*bb
            evdwij=e_augm+e1+e2
            ij=icant(itypi,itypj)
cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
            if (bb.gt.0.0d0) then
              evdw=evdw+evdwij
            else 
              evdw_t=evdw_t+evdwij
            endif
            if (calc_grad) then
C 
C Calculate the components of the gradient in DC and X
C
            fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
            gg(1)=xj*fac
            gg(2)=yj*fac
            gg(3)=zj*fac
            do k=1,3
              gvdwx(k,i)=gvdwx(k,i)-gg(k)
              gvdwx(k,j)=gvdwx(k,j)+gg(k)
            enddo
            do k=i,j-1
              do l=1,3
                gvdwc(l,k)=gvdwc(l,k)+gg(l)
              enddo
            enddo
            endif
          enddo      ! j
        enddo        ! iint
      enddo          ! i
      if (calc_grad) then
      do i=1,nct
        do j=1,3
          gvdwc(j,i)=expon*gvdwc(j,i)
          gvdwx(j,i)=expon*gvdwx(j,i)
        enddo
      enddo
      endif
      return
      end
C-----------------------------------------------------------------------------
      subroutine ebp(evdw,evdw_t)
C
C This subroutine calculates the interaction energy of nonbonded side chains
C assuming the Berne-Pechukas potential of interaction.
C
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include "DIMENSIONS.COMPAR"
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.NAMES'
      include 'COMMON.INTERACT'
      include 'COMMON.IOUNITS'
      include 'COMMON.CALC'
      common /srutu/ icall
c     double precision rrsave(maxdim)
      logical lprn
      integer icant
      external icant
      evdw=0.0D0
      evdw_t=0.0d0
c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
c     if (icall.eq.0) then
c       lprn=.true.
c     else
        lprn=.false.
c     endif
      ind=0
      do i=iatsc_s,iatsc_e
        itypi=iabs(itype(i))
        if (itypi.eq.ntyp1) cycle
        itypi1=iabs(itype(i+1))
        xi=c(1,nres+i)
        yi=c(2,nres+i)
        zi=c(3,nres+i)
        dxi=dc_norm(1,nres+i)
        dyi=dc_norm(2,nres+i)
        dzi=dc_norm(3,nres+i)
        dsci_inv=vbld_inv(i+nres)
C
C Calculate SC interaction energy.
C
        do iint=1,nint_gr(i)
          do j=istart(i,iint),iend(i,iint)
            ind=ind+1
            itypj=iabs(itype(j))
            if (itypj.eq.ntyp1) cycle
            dscj_inv=vbld_inv(j+nres)
            chi1=chi(itypi,itypj)
            chi2=chi(itypj,itypi)
            chi12=chi1*chi2
            chip1=chip(itypi)
            chip2=chip(itypj)
            chip12=chip1*chip2
            alf1=alp(itypi)
            alf2=alp(itypj)
            alf12=0.5D0*(alf1+alf2)
C For diagnostics only!!!
c           chi1=0.0D0
c           chi2=0.0D0
c           chi12=0.0D0
c           chip1=0.0D0
c           chip2=0.0D0
c           chip12=0.0D0
c           alf1=0.0D0
c           alf2=0.0D0
c           alf12=0.0D0
            xj=c(1,nres+j)-xi
            yj=c(2,nres+j)-yi
            zj=c(3,nres+j)-zi
            dxj=dc_norm(1,nres+j)
            dyj=dc_norm(2,nres+j)
            dzj=dc_norm(3,nres+j)
            rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
cd          if (icall.eq.0) then
cd            rrsave(ind)=rrij
cd          else
cd            rrij=rrsave(ind)
cd          endif
            rij=dsqrt(rrij)
C Calculate the angle-dependent terms of energy & contributions to derivatives.
            call sc_angular
C Calculate whole angle-dependent part of epsilon and contributions
C to its derivatives
            fac=(rrij*sigsq)**expon2
            e1=fac*fac*aa
            e2=fac*bb
            evdwij=eps1*eps2rt*eps3rt*(e1+e2)
            eps2der=evdwij*eps3rt
            eps3der=evdwij*eps2rt
            evdwij=evdwij*eps2rt*eps3rt
            ij=icant(itypi,itypj)
            aux=eps1*eps2rt**2*eps3rt**2
            if (bb.gt.0.0d0) then
              evdw=evdw+evdwij
            else
              evdw_t=evdw_t+evdwij
            endif
            if (calc_grad) then
            if (lprn) then
            sigm=dabs(aa/bb)**(1.0D0/6.0D0)
            epsi=bb**2/aa
cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
cd     &        restyp(itypi),i,restyp(itypj),j,
cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
cd     &        evdwij
            endif
C Calculate gradient components.
            e1=e1*eps1*eps2rt**2*eps3rt**2
            fac=-expon*(e1+evdwij)
            sigder=fac/sigsq
            fac=rrij*fac
C Calculate radial part of the gradient
            gg(1)=xj*fac
            gg(2)=yj*fac
            gg(3)=zj*fac
C Calculate the angular part of the gradient and sum add the contributions
C to the appropriate components of the Cartesian gradient.
            call sc_grad
            endif
          enddo      ! j
        enddo        ! iint
      enddo          ! i
c     stop
      return
      end
C-----------------------------------------------------------------------------
      subroutine egb(evdw,evdw_t)
C
C This subroutine calculates the interaction energy of nonbonded side chains
C assuming the Gay-Berne potential of interaction.
C
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include "DIMENSIONS.COMPAR"
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.NAMES'
      include 'COMMON.INTERACT'
      include 'COMMON.IOUNITS'
      include 'COMMON.CALC'
      include 'COMMON.SBRIDGE'
      logical lprn
      common /srutu/icall
      integer icant
      external icant
      integer xshift,yshift,zshift
      logical energy_dec /.false./
c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
      evdw=0.0D0
      evdw_t=0.0d0
      lprn=.false.
c      if (icall.gt.0) lprn=.true.
      ind=0
      do i=iatsc_s,iatsc_e
        itypi=iabs(itype(i))
        if (itypi.eq.ntyp1) cycle
        itypi1=iabs(itype(i+1))
        xi=c(1,nres+i)
        yi=c(2,nres+i)
        zi=c(3,nres+i)
          xi=mod(xi,boxxsize)
          if (xi.lt.0) xi=xi+boxxsize
          yi=mod(yi,boxysize)
          if (yi.lt.0) yi=yi+boxysize
          zi=mod(zi,boxzsize)
          if (zi.lt.0) zi=zi+boxzsize
       if ((zi.gt.bordlipbot)
     &.and.(zi.lt.bordliptop)) then
C the energy transfer exist
        if (zi.lt.buflipbot) then
C what fraction I am in
         fracinbuf=1.0d0-
     &        ((zi-bordlipbot)/lipbufthick)
C lipbufthick is thickenes of lipid buffore
         sslipi=sscalelip(fracinbuf)
         ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
        elseif (zi.gt.bufliptop) then
         fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
         sslipi=sscalelip(fracinbuf)
         ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
        else
         sslipi=1.0d0
         ssgradlipi=0.0
        endif
       else
         sslipi=0.0d0
         ssgradlipi=0.0
       endif
        dxi=dc_norm(1,nres+i)
        dyi=dc_norm(2,nres+i)
        dzi=dc_norm(3,nres+i)
        dsci_inv=vbld_inv(i+nres)
C
C Calculate SC interaction energy.
C
        do iint=1,nint_gr(i)
          do j=istart(i,iint),iend(i,iint)
            IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN

c              write(iout,*) "PRZED ZWYKLE", evdwij
              call dyn_ssbond_ene(i,j,evdwij)
c              write(iout,*) "PO ZWYKLE", evdwij

              evdw=evdw+evdwij
              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
     &                        'evdw',i,j,evdwij,' ss'
C triple bond artifac removal
             do k=j+1,iend(i,iint)
C search over all next residues
              if (dyn_ss_mask(k)) then
C check if they are cysteins
C              write(iout,*) 'k=',k

c              write(iout,*) "PRZED TRI", evdwij
               evdwij_przed_tri=evdwij
              call triple_ssbond_ene(i,j,k,evdwij)
c               if(evdwij_przed_tri.ne.evdwij) then
c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
c               endif

c              write(iout,*) "PO TRI", evdwij
C call the energy function that removes the artifical triple disulfide
C bond the soubroutine is located in ssMD.F
              evdw=evdw+evdwij
              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
     &                        'evdw',i,j,evdwij,'tss'
              endif!dyn_ss_mask(k)
             enddo! k
            ELSE
            ind=ind+1
            itypj=iabs(itype(j))
            if (itypj.eq.ntyp1) cycle
            dscj_inv=vbld_inv(j+nres)
            sig0ij=sigma(itypi,itypj)
            chi1=chi(itypi,itypj)
            chi2=chi(itypj,itypi)
            chi12=chi1*chi2
            chip1=chip(itypi)
            chip2=chip(itypj)
            chip12=chip1*chip2
            alf1=alp(itypi)
            alf2=alp(itypj)
            alf12=0.5D0*(alf1+alf2)
C For diagnostics only!!!
c           chi1=0.0D0
c           chi2=0.0D0
c           chi12=0.0D0
c           chip1=0.0D0
c           chip2=0.0D0
c           chip12=0.0D0
c           alf1=0.0D0
c           alf2=0.0D0
c           alf12=0.0D0
            xj=c(1,nres+j)
            yj=c(2,nres+j)
            zj=c(3,nres+j)
          xj=mod(xj,boxxsize)
          if (xj.lt.0) xj=xj+boxxsize
          yj=mod(yj,boxysize)
          if (yj.lt.0) yj=yj+boxysize
          zj=mod(zj,boxzsize)
          if (zj.lt.0) zj=zj+boxzsize
       if ((zj.gt.bordlipbot)
     &.and.(zj.lt.bordliptop)) then
C the energy transfer exist
        if (zj.lt.buflipbot) then
C what fraction I am in
         fracinbuf=1.0d0-
     &        ((zj-bordlipbot)/lipbufthick)
C lipbufthick is thickenes of lipid buffore
         sslipj=sscalelip(fracinbuf)
         ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
        elseif (zj.gt.bufliptop) then
         fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
         sslipj=sscalelip(fracinbuf)
         ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
        else
         sslipj=1.0d0
         ssgradlipj=0.0
        endif
       else
         sslipj=0.0d0
         ssgradlipj=0.0
       endif
      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
     &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
     &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
C      write(iout,*) "czy jest 0", bb-bb_lip(itypi,itypj),              
C     & bb-bb_aq(itypi,itypj)
      dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
      xj_safe=xj
      yj_safe=yj
      zj_safe=zj
      subchap=0
      do xshift=-1,1
      do yshift=-1,1
      do zshift=-1,1
          xj=xj_safe+xshift*boxxsize
          yj=yj_safe+yshift*boxysize
          zj=zj_safe+zshift*boxzsize
          dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
          if(dist_temp.lt.dist_init) then
            dist_init=dist_temp
            xj_temp=xj
            yj_temp=yj
            zj_temp=zj
            subchap=1
          endif
       enddo
       enddo
       enddo
       if (subchap.eq.1) then
          xj=xj_temp-xi
          yj=yj_temp-yi
          zj=zj_temp-zi
       else
          xj=xj_safe-xi
          yj=yj_safe-yi
          zj=zj_safe-zi
       endif
            dxj=dc_norm(1,nres+j)
            dyj=dc_norm(2,nres+j)
            dzj=dc_norm(3,nres+j)
c            write (iout,*) i,j,xj,yj,zj
            rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
            rij=dsqrt(rrij)
            sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
            sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
            if (sss.le.0.0d0) cycle
C Calculate angle-dependent terms of energy and contributions to their
C derivatives.
            call sc_angular
            sigsq=1.0D0/sigsq
            sig=sig0ij*dsqrt(sigsq)
            rij_shift=1.0D0/rij-sig+sig0ij
C I hate to put IF's in the loops, but here don't have another choice!!!!
            if (rij_shift.le.0.0D0) then
              evdw=1.0D20
              return
            endif
            sigder=-sig*sigsq
c---------------------------------------------------------------
            rij_shift=1.0D0/rij_shift 
            fac=rij_shift**expon
            e1=fac*fac*aa
            e2=fac*bb
            evdwij=eps1*eps2rt*eps3rt*(e1+e2)
            eps2der=evdwij*eps3rt
            eps3der=evdwij*eps2rt
            evdwij=evdwij*eps2rt*eps3rt
            if (bb.gt.0) then
              evdw=evdw+evdwij*sss
            else
              evdw_t=evdw_t+evdwij*sss
            endif
            ij=icant(itypi,itypj)
            aux=eps1*eps2rt**2*eps3rt**2
c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
c     &         aux*e2/eps(itypi,itypj)
c            if (lprn) then
            sigm=dabs(aa/bb)**(1.0D0/6.0D0)
            epsi=bb**2/aa
C#define DEBUG
#ifdef DEBUG
C            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
C     &        restyp(itypi),i,restyp(itypj),j,
C     &        epsi,sigm,chi1,chi2,chip1,chip2,
C     &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
C     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
C     &        evdwij
             write (iout,*) "pratial sum", evdw,evdw_t,e1,e2,fac,aa
#endif
C#undef DEBUG
c            endif
            if (calc_grad) then
C Calculate gradient components.
            e1=e1*eps1*eps2rt**2*eps3rt**2
            fac=-expon*(e1+evdwij)*rij_shift
            sigder=fac*sigder
            fac=rij*fac
            fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
            gg_lipi(3)=eps1*(eps2rt*eps2rt)
     &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
     & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
     &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
            gg_lipj(3)=ssgradlipj*gg_lipi(3)
            gg_lipi(3)=gg_lipi(3)*ssgradlipi
C Calculate the radial part of the gradient
            gg(1)=xj*fac
            gg(2)=yj*fac
            gg(3)=zj*fac
C Calculate angular part of the gradient.
            call sc_grad
            endif
            ENDIF    ! dyn_ss            
          enddo      ! j
        enddo        ! iint
      enddo          ! i
      return
      end
C-----------------------------------------------------------------------------
      subroutine egbv(evdw,evdw_t)
C
C This subroutine calculates the interaction energy of nonbonded side chains
C assuming the Gay-Berne-Vorobjev potential of interaction.
C
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include "DIMENSIONS.COMPAR"
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.NAMES'
      include 'COMMON.INTERACT'
      include 'COMMON.IOUNITS'
      include 'COMMON.CALC'
      common /srutu/ icall
      logical lprn
      integer icant
      external icant
      evdw=0.0D0
      evdw_t=0.0d0
c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
      evdw=0.0D0
      lprn=.false.
c      if (icall.gt.0) lprn=.true.
      ind=0
      do i=iatsc_s,iatsc_e
        itypi=iabs(itype(i))
        if (itypi.eq.ntyp1) cycle
        itypi1=iabs(itype(i+1))
        xi=c(1,nres+i)
        yi=c(2,nres+i)
        zi=c(3,nres+i)
        dxi=dc_norm(1,nres+i)
        dyi=dc_norm(2,nres+i)
        dzi=dc_norm(3,nres+i)
        dsci_inv=vbld_inv(i+nres)
C returning the ith atom to box
          xi=mod(xi,boxxsize)
          if (xi.lt.0) xi=xi+boxxsize
          yi=mod(yi,boxysize)
          if (yi.lt.0) yi=yi+boxysize
          zi=mod(zi,boxzsize)
          if (zi.lt.0) zi=zi+boxzsize
       if ((zi.gt.bordlipbot)
     &.and.(zi.lt.bordliptop)) then
C the energy transfer exist
        if (zi.lt.buflipbot) then
C what fraction I am in
         fracinbuf=1.0d0-
     &        ((zi-bordlipbot)/lipbufthick)
C lipbufthick is thickenes of lipid buffore
         sslipi=sscalelip(fracinbuf)
         ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
        elseif (zi.gt.bufliptop) then
         fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
         sslipi=sscalelip(fracinbuf)
         ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
        else
         sslipi=1.0d0
         ssgradlipi=0.0
        endif
       else
         sslipi=0.0d0
         ssgradlipi=0.0
       endif
C
C Calculate SC interaction energy.
C
        do iint=1,nint_gr(i)
          do j=istart(i,iint),iend(i,iint)
            ind=ind+1
            itypj=iabs(itype(j))
            if (itypj.eq.ntyp1) cycle
            dscj_inv=vbld_inv(j+nres)
            sig0ij=sigma(itypi,itypj)
            r0ij=r0(itypi,itypj)
            chi1=chi(itypi,itypj)
            chi2=chi(itypj,itypi)
            chi12=chi1*chi2
            chip1=chip(itypi)
            chip2=chip(itypj)
            chip12=chip1*chip2
            alf1=alp(itypi)
            alf2=alp(itypj)
            alf12=0.5D0*(alf1+alf2)
C For diagnostics only!!!
c           chi1=0.0D0
c           chi2=0.0D0
c           chi12=0.0D0
c           chip1=0.0D0
c           chip2=0.0D0
c           chip12=0.0D0
c           alf1=0.0D0
c           alf2=0.0D0
c           alf12=0.0D0
            xj=c(1,nres+j)
            yj=c(2,nres+j)
            zj=c(3,nres+j)
C returning jth atom to box
          xj=mod(xj,boxxsize)
          if (xj.lt.0) xj=xj+boxxsize
          yj=mod(yj,boxysize)
          if (yj.lt.0) yj=yj+boxysize
          zj=mod(zj,boxzsize)
          if (zj.lt.0) zj=zj+boxzsize
       if ((zj.gt.bordlipbot)
     &.and.(zj.lt.bordliptop)) then
C the energy transfer exist
        if (zj.lt.buflipbot) then
C what fraction I am in
         fracinbuf=1.0d0-
     &        ((zj-bordlipbot)/lipbufthick)
C lipbufthick is thickenes of lipid buffore
         sslipj=sscalelip(fracinbuf)
         ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
        elseif (zj.gt.bufliptop) then
         fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
         sslipj=sscalelip(fracinbuf)
         ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
        else
         sslipj=1.0d0
         ssgradlipj=0.0
        endif
       else
         sslipj=0.0d0
         ssgradlipj=0.0
       endif
      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
     &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
     &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
C checking the distance
      dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
      xj_safe=xj
      yj_safe=yj
      zj_safe=zj
      subchap=0
C finding the closest
      do xshift=-1,1
      do yshift=-1,1
      do zshift=-1,1
          xj=xj_safe+xshift*boxxsize
          yj=yj_safe+yshift*boxysize
          zj=zj_safe+zshift*boxzsize
          dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
          if(dist_temp.lt.dist_init) then
            dist_init=dist_temp
            xj_temp=xj
            yj_temp=yj
            zj_temp=zj
            subchap=1
          endif
       enddo
       enddo
       enddo
       if (subchap.eq.1) then
          xj=xj_temp-xi
          yj=yj_temp-yi
          zj=zj_temp-zi
       else
          xj=xj_safe-xi
          yj=yj_safe-yi
          zj=zj_safe-zi
       endif
            dxj=dc_norm(1,nres+j)
            dyj=dc_norm(2,nres+j)
            dzj=dc_norm(3,nres+j)
            rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
            rij=dsqrt(rrij)
C Calculate angle-dependent terms of energy and contributions to their
C derivatives.
            call sc_angular
            sigsq=1.0D0/sigsq
            sig=sig0ij*dsqrt(sigsq)
            rij_shift=1.0D0/rij-sig+r0ij
C I hate to put IF's in the loops, but here don't have another choice!!!!
            if (rij_shift.le.0.0D0) then
              evdw=1.0D20
              return
            endif
            sigder=-sig*sigsq
c---------------------------------------------------------------
            rij_shift=1.0D0/rij_shift 
            fac=rij_shift**expon
            e1=fac*fac*aa
            e2=fac*bb
            evdwij=eps1*eps2rt*eps3rt*(e1+e2)
            eps2der=evdwij*eps3rt
            eps3der=evdwij*eps2rt
            fac_augm=rrij**expon
            e_augm=augm(itypi,itypj)*fac_augm
            evdwij=evdwij*eps2rt*eps3rt
            if (bb.gt.0.0d0) then
              evdw=evdw+evdwij+e_augm
            else
              evdw_t=evdw_t+evdwij+e_augm
            endif
            ij=icant(itypi,itypj)
            aux=eps1*eps2rt**2*eps3rt**2
c            if (lprn) then
c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
c     &        restyp(itypi),i,restyp(itypj),j,
c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
c     &        chi1,chi2,chip1,chip2,
c     &        eps1,eps2rt**2,eps3rt**2,
c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
c     &        evdwij+e_augm
c            endif
            if (calc_grad) then
C Calculate gradient components.
            e1=e1*eps1*eps2rt**2*eps3rt**2
            fac=-expon*(e1+evdwij)*rij_shift
            sigder=fac*sigder
            fac=rij*fac-2*expon*rrij*e_augm
C Calculate the radial part of the gradient
            gg(1)=xj*fac
            gg(2)=yj*fac
            gg(3)=zj*fac
C Calculate angular part of the gradient.
            call sc_grad
            endif
          enddo      ! j
        enddo        ! iint
      enddo          ! i
      return
      end
C-----------------------------------------------------------------------------
      subroutine sc_angular
C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
C om12. Called by ebp, egb, and egbv.
      implicit none
      include 'COMMON.CALC'
      erij(1)=xj*rij
      erij(2)=yj*rij
      erij(3)=zj*rij
      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
      om12=dxi*dxj+dyi*dyj+dzi*dzj
      chiom12=chi12*om12
C Calculate eps1(om12) and its derivative in om12
      faceps1=1.0D0-om12*chiom12
      faceps1_inv=1.0D0/faceps1
      eps1=dsqrt(faceps1_inv)
C Following variable is eps1*deps1/dom12
      eps1_om12=faceps1_inv*chiom12
C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
C and om12.
      om1om2=om1*om2
      chiom1=chi1*om1
      chiom2=chi2*om2
      facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
      sigsq=1.0D0-facsig*faceps1_inv
      sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
      sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
      sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
C Calculate eps2 and its derivatives in om1, om2, and om12.
      chipom1=chip1*om1
      chipom2=chip2*om2
      chipom12=chip12*om12
      facp=1.0D0-om12*chipom12
      facp_inv=1.0D0/facp
      facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
C Following variable is the square root of eps2
      eps2rt=1.0D0-facp1*facp_inv
C Following three variables are the derivatives of the square root of eps
C in om1, om2, and om12.
      eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
      eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
      eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2 
C Evaluate the "asymmetric" factor in the VDW constant, eps3
      eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12 
C Calculate whole angle-dependent part of epsilon and contributions
C to its derivatives
      return
      end
C----------------------------------------------------------------------------
      subroutine sc_grad
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.CALC'
      double precision dcosom1(3),dcosom2(3)
      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
     &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
      do k=1,3
        dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
        dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
      enddo
      do k=1,3
        gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
      enddo 
      do k=1,3
        gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
     &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
        gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipi(k)
     &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
      enddo
C 
C Calculate the components of the gradient in DC and X
C
      do k=i,j-1
        do l=1,3
          gvdwc(l,k)=gvdwc(l,k)+gg(l)+gg_lipi(l)
        enddo
      enddo
      do l=1,3
         gvdwc(l,j)=gvdwc(l,j)+gg_lipj(l)
      enddo
      return
      end
c------------------------------------------------------------------------------
      subroutine vec_and_deriv
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.VECTORS'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
C Compute the local reference systems. For reference system (i), the
C X-axis points from CA(i) to CA(i+1), the Y axis is in the 
C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
      do i=1,nres-1
c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
          if (i.eq.nres-1) then
C Case of the last full residue
C Compute the Z-axis
            call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
            costh=dcos(pi-theta(nres))
            fac=1.0d0/dsqrt(1.0d0-costh*costh)
            do k=1,3
              uz(k,i)=fac*uz(k,i)
            enddo
            if (calc_grad) then
C Compute the derivatives of uz
            uzder(1,1,1)= 0.0d0
            uzder(2,1,1)=-dc_norm(3,i-1)
            uzder(3,1,1)= dc_norm(2,i-1) 
            uzder(1,2,1)= dc_norm(3,i-1)
            uzder(2,2,1)= 0.0d0
            uzder(3,2,1)=-dc_norm(1,i-1)
            uzder(1,3,1)=-dc_norm(2,i-1)
            uzder(2,3,1)= dc_norm(1,i-1)
            uzder(3,3,1)= 0.0d0
            uzder(1,1,2)= 0.0d0
            uzder(2,1,2)= dc_norm(3,i)
            uzder(3,1,2)=-dc_norm(2,i) 
            uzder(1,2,2)=-dc_norm(3,i)
            uzder(2,2,2)= 0.0d0
            uzder(3,2,2)= dc_norm(1,i)
            uzder(1,3,2)= dc_norm(2,i)
            uzder(2,3,2)=-dc_norm(1,i)
            uzder(3,3,2)= 0.0d0
            endif
C Compute the Y-axis
            facy=fac
            do k=1,3
              uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
            enddo
            if (calc_grad) then
C Compute the derivatives of uy
            do j=1,3
              do k=1,3
                uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
     &                        -dc_norm(k,i)*dc_norm(j,i-1)
                uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
              enddo
              uyder(j,j,1)=uyder(j,j,1)-costh
              uyder(j,j,2)=1.0d0+uyder(j,j,2)
            enddo
            do j=1,2
              do k=1,3
                do l=1,3
                  uygrad(l,k,j,i)=uyder(l,k,j)
                  uzgrad(l,k,j,i)=uzder(l,k,j)
                enddo
              enddo
            enddo 
            call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
            call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
            call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
            call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
            endif
          else
C Other residues
C Compute the Z-axis
            call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
            costh=dcos(pi-theta(i+2))
            fac=1.0d0/dsqrt(1.0d0-costh*costh)
            do k=1,3
              uz(k,i)=fac*uz(k,i)
            enddo
            if (calc_grad) then
C Compute the derivatives of uz
            uzder(1,1,1)= 0.0d0
            uzder(2,1,1)=-dc_norm(3,i+1)
            uzder(3,1,1)= dc_norm(2,i+1) 
            uzder(1,2,1)= dc_norm(3,i+1)
            uzder(2,2,1)= 0.0d0
            uzder(3,2,1)=-dc_norm(1,i+1)
            uzder(1,3,1)=-dc_norm(2,i+1)
            uzder(2,3,1)= dc_norm(1,i+1)
            uzder(3,3,1)= 0.0d0
            uzder(1,1,2)= 0.0d0
            uzder(2,1,2)= dc_norm(3,i)
            uzder(3,1,2)=-dc_norm(2,i) 
            uzder(1,2,2)=-dc_norm(3,i)
            uzder(2,2,2)= 0.0d0
            uzder(3,2,2)= dc_norm(1,i)
            uzder(1,3,2)= dc_norm(2,i)
            uzder(2,3,2)=-dc_norm(1,i)
            uzder(3,3,2)= 0.0d0
            endif
C Compute the Y-axis
            facy=fac
            do k=1,3
              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
            enddo
            if (calc_grad) then
C Compute the derivatives of uy
            do j=1,3
              do k=1,3
                uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
     &                        -dc_norm(k,i)*dc_norm(j,i+1)
                uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
              enddo
              uyder(j,j,1)=uyder(j,j,1)-costh
              uyder(j,j,2)=1.0d0+uyder(j,j,2)
            enddo
            do j=1,2
              do k=1,3
                do l=1,3
                  uygrad(l,k,j,i)=uyder(l,k,j)
                  uzgrad(l,k,j,i)=uzder(l,k,j)
                enddo
              enddo
            enddo 
            call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
            call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
            call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
            call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
          endif
          endif
      enddo
      if (calc_grad) then
      do i=1,nres-1
        vbld_inv_temp(1)=vbld_inv(i+1)
        if (i.lt.nres-1) then
          vbld_inv_temp(2)=vbld_inv(i+2)
        else
          vbld_inv_temp(2)=vbld_inv(i)
        endif
        do j=1,2
          do k=1,3
            do l=1,3
              uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
              uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
            enddo
          enddo
        enddo
      enddo
      endif
      return
      end
C-----------------------------------------------------------------------------
      subroutine vec_and_deriv_test
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.VECTORS'
      dimension uyder(3,3,2),uzder(3,3,2)
C Compute the local reference systems. For reference system (i), the
C X-axis points from CA(i) to CA(i+1), the Y axis is in the 
C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
      do i=1,nres-1
          if (i.eq.nres-1) then
C Case of the last full residue
C Compute the Z-axis
            call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
            costh=dcos(pi-theta(nres))
            fac=1.0d0/dsqrt(1.0d0-costh*costh)
c            write (iout,*) 'fac',fac,
c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
            fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
            do k=1,3
              uz(k,i)=fac*uz(k,i)
            enddo
C Compute the derivatives of uz
            uzder(1,1,1)= 0.0d0
            uzder(2,1,1)=-dc_norm(3,i-1)
            uzder(3,1,1)= dc_norm(2,i-1) 
            uzder(1,2,1)= dc_norm(3,i-1)
            uzder(2,2,1)= 0.0d0
            uzder(3,2,1)=-dc_norm(1,i-1)
            uzder(1,3,1)=-dc_norm(2,i-1)
            uzder(2,3,1)= dc_norm(1,i-1)
            uzder(3,3,1)= 0.0d0
            uzder(1,1,2)= 0.0d0
            uzder(2,1,2)= dc_norm(3,i)
            uzder(3,1,2)=-dc_norm(2,i) 
            uzder(1,2,2)=-dc_norm(3,i)
            uzder(2,2,2)= 0.0d0
            uzder(3,2,2)= dc_norm(1,i)
            uzder(1,3,2)= dc_norm(2,i)
            uzder(2,3,2)=-dc_norm(1,i)
            uzder(3,3,2)= 0.0d0
C Compute the Y-axis
            do k=1,3
              uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
            enddo
            facy=fac
            facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
     &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
     &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
            do k=1,3
c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
              uy(k,i)=
c     &        facy*(
     &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
     &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
c     &        )
            enddo
c            write (iout,*) 'facy',facy,
c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
            facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
            do k=1,3
              uy(k,i)=facy*uy(k,i)
            enddo
C Compute the derivatives of uy
            do j=1,3
              do k=1,3
                uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
     &                        -dc_norm(k,i)*dc_norm(j,i-1)
                uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
              enddo
c              uyder(j,j,1)=uyder(j,j,1)-costh
c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
              uyder(j,j,1)=uyder(j,j,1)
     &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
              uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
     &          +uyder(j,j,2)
            enddo
            do j=1,2
              do k=1,3
                do l=1,3
                  uygrad(l,k,j,i)=uyder(l,k,j)
                  uzgrad(l,k,j,i)=uzder(l,k,j)
                enddo
              enddo
            enddo 
            call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
            call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
            call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
            call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
          else
C Other residues
C Compute the Z-axis
            call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
            costh=dcos(pi-theta(i+2))
            fac=1.0d0/dsqrt(1.0d0-costh*costh)
            fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
            do k=1,3
              uz(k,i)=fac*uz(k,i)
            enddo
C Compute the derivatives of uz
            uzder(1,1,1)= 0.0d0
            uzder(2,1,1)=-dc_norm(3,i+1)
            uzder(3,1,1)= dc_norm(2,i+1) 
            uzder(1,2,1)= dc_norm(3,i+1)
            uzder(2,2,1)= 0.0d0
            uzder(3,2,1)=-dc_norm(1,i+1)
            uzder(1,3,1)=-dc_norm(2,i+1)
            uzder(2,3,1)= dc_norm(1,i+1)
            uzder(3,3,1)= 0.0d0
            uzder(1,1,2)= 0.0d0
            uzder(2,1,2)= dc_norm(3,i)
            uzder(3,1,2)=-dc_norm(2,i) 
            uzder(1,2,2)=-dc_norm(3,i)
            uzder(2,2,2)= 0.0d0
            uzder(3,2,2)= dc_norm(1,i)
            uzder(1,3,2)= dc_norm(2,i)
            uzder(2,3,2)=-dc_norm(1,i)
            uzder(3,3,2)= 0.0d0
C Compute the Y-axis
            facy=fac
            facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
     &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
     &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
            do k=1,3
c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
              uy(k,i)=
c     &        facy*(
     &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
     &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
c     &        )
            enddo
c            write (iout,*) 'facy',facy,
c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
            facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
            do k=1,3
              uy(k,i)=facy*uy(k,i)
            enddo
C Compute the derivatives of uy
            do j=1,3
              do k=1,3
                uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
     &                        -dc_norm(k,i)*dc_norm(j,i+1)
                uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
              enddo
c              uyder(j,j,1)=uyder(j,j,1)-costh
c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
              uyder(j,j,1)=uyder(j,j,1)
     &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
              uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
     &          +uyder(j,j,2)
            enddo
            do j=1,2
              do k=1,3
                do l=1,3
                  uygrad(l,k,j,i)=uyder(l,k,j)
                  uzgrad(l,k,j,i)=uzder(l,k,j)
                enddo
              enddo
            enddo 
            call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
            call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
            call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
            call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
          endif
      enddo
      do i=1,nres-1
        do j=1,2
          do k=1,3
            do l=1,3
              uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
              uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
            enddo
          enddo
        enddo
      enddo
      return
      end
C-----------------------------------------------------------------------------
      subroutine check_vecgrad
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.VECTORS'
      dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
      dimension uyt(3,maxres),uzt(3,maxres)
      dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
      double precision delta /1.0d-7/
      call vec_and_deriv
cd      do i=1,nres
crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
cd     &     (dc_norm(if90,i),if90=1,3)
cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
cd          write(iout,'(a)')
cd      enddo
      do i=1,nres
        do j=1,2
          do k=1,3
            do l=1,3
              uygradt(l,k,j,i)=uygrad(l,k,j,i)
              uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
            enddo
          enddo
        enddo
      enddo
      call vec_and_deriv
      do i=1,nres
        do j=1,3
          uyt(j,i)=uy(j,i)
          uzt(j,i)=uz(j,i)
        enddo
      enddo
      do i=1,nres
cd        write (iout,*) 'i=',i
        do k=1,3
          erij(k)=dc_norm(k,i)
        enddo
        do j=1,3
          do k=1,3
            dc_norm(k,i)=erij(k)
          enddo
          dc_norm(j,i)=dc_norm(j,i)+delta
c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
c          do k=1,3
c            dc_norm(k,i)=dc_norm(k,i)/fac
c          enddo
c          write (iout,*) (dc_norm(k,i),k=1,3)
c          write (iout,*) (erij(k),k=1,3)
          call vec_and_deriv
          do k=1,3
            uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
            uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
            uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
            uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
          enddo 
c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') 
c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
        enddo
        do k=1,3
          dc_norm(k,i)=erij(k)
        enddo
cd        do k=1,3
cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') 
cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') 
cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
cd          write (iout,'(a)')
cd        enddo
      enddo
      return
      end
C--------------------------------------------------------------------------
      subroutine set_matrices
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.TORSION'
      include 'COMMON.VECTORS'
      include 'COMMON.FFIELD'
      double precision auxvec(2),auxmat(2,2)
C
C Compute the virtual-bond-torsional-angle dependent quantities needed
C to calculate the el-loc multibody terms of various order.
C
      do i=3,nres+1
        if (i .lt. nres+1) then
          sin1=dsin(phi(i))
          cos1=dcos(phi(i))
          sintab(i-2)=sin1
          costab(i-2)=cos1
          obrot(1,i-2)=cos1
          obrot(2,i-2)=sin1
          sin2=dsin(2*phi(i))
          cos2=dcos(2*phi(i))
          sintab2(i-2)=sin2
          costab2(i-2)=cos2
          obrot2(1,i-2)=cos2
          obrot2(2,i-2)=sin2
          Ug(1,1,i-2)=-cos1
          Ug(1,2,i-2)=-sin1
          Ug(2,1,i-2)=-sin1
          Ug(2,2,i-2)= cos1
          Ug2(1,1,i-2)=-cos2
          Ug2(1,2,i-2)=-sin2
          Ug2(2,1,i-2)=-sin2
          Ug2(2,2,i-2)= cos2
        else
          costab(i-2)=1.0d0
          sintab(i-2)=0.0d0
          obrot(1,i-2)=1.0d0
          obrot(2,i-2)=0.0d0
          obrot2(1,i-2)=0.0d0
          obrot2(2,i-2)=0.0d0
          Ug(1,1,i-2)=1.0d0
          Ug(1,2,i-2)=0.0d0
          Ug(2,1,i-2)=0.0d0
          Ug(2,2,i-2)=1.0d0
          Ug2(1,1,i-2)=0.0d0
          Ug2(1,2,i-2)=0.0d0
          Ug2(2,1,i-2)=0.0d0
          Ug2(2,2,i-2)=0.0d0
        endif
        if (i .gt. 3 .and. i .lt. nres+1) then
          obrot_der(1,i-2)=-sin1
          obrot_der(2,i-2)= cos1
          Ugder(1,1,i-2)= sin1
          Ugder(1,2,i-2)=-cos1
          Ugder(2,1,i-2)=-cos1
          Ugder(2,2,i-2)=-sin1
          dwacos2=cos2+cos2
          dwasin2=sin2+sin2
          obrot2_der(1,i-2)=-dwasin2
          obrot2_der(2,i-2)= dwacos2
          Ug2der(1,1,i-2)= dwasin2
          Ug2der(1,2,i-2)=-dwacos2
          Ug2der(2,1,i-2)=-dwacos2
          Ug2der(2,2,i-2)=-dwasin2
        else
          obrot_der(1,i-2)=0.0d0
          obrot_der(2,i-2)=0.0d0
          Ugder(1,1,i-2)=0.0d0
          Ugder(1,2,i-2)=0.0d0
          Ugder(2,1,i-2)=0.0d0
          Ugder(2,2,i-2)=0.0d0
          obrot2_der(1,i-2)=0.0d0
          obrot2_der(2,i-2)=0.0d0
          Ug2der(1,1,i-2)=0.0d0
          Ug2der(1,2,i-2)=0.0d0
          Ug2der(2,1,i-2)=0.0d0
          Ug2der(2,2,i-2)=0.0d0
        endif
        if (i.gt. nnt+2 .and. i.lt.nct+2) then
          if (itype(i-2).le.ntyp) then
            iti = itortyp(itype(i-2))
          else 
            iti=ntortyp+1
          endif
        else
          iti=ntortyp+1
        endif
        if (i.gt. nnt+1 .and. i.lt.nct+1) then
          if (itype(i-1).le.ntyp) then
            iti1 = itortyp(itype(i-1))
          else
            iti1=ntortyp+1
          endif
        else
          iti1=ntortyp+1
        endif
cd        write (iout,*) '*******i',i,' iti1',iti
cd        write (iout,*) 'b1',b1(:,iti)
cd        write (iout,*) 'b2',b2(:,iti)
cd        write (iout,*) 'Ug',Ug(:,:,i-2)
c        print *,"itilde1 i iti iti1",i,iti,iti1
        if (i .gt. iatel_s+2) then
          call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
          call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
          call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
          call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
          call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
          call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
          call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
        else
          do k=1,2
            Ub2(k,i-2)=0.0d0
            Ctobr(k,i-2)=0.0d0 
            Dtobr2(k,i-2)=0.0d0
            do l=1,2
              EUg(l,k,i-2)=0.0d0
              CUg(l,k,i-2)=0.0d0
              DUg(l,k,i-2)=0.0d0
              DtUg2(l,k,i-2)=0.0d0
            enddo
          enddo
        endif
c        print *,"itilde2 i iti iti1",i,iti,iti1
        call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
        call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
        call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
        call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
        call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
        call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
        call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
c        print *,"itilde3 i iti iti1",i,iti,iti1
        do k=1,2
          muder(k,i-2)=Ub2der(k,i-2)
        enddo
        if (i.gt. nnt+1 .and. i.lt.nct+1) then
          if (itype(i-1).le.ntyp) then
            iti1 = itortyp(itype(i-1))
          else
            iti1=ntortyp+1
          endif
        else
          iti1=ntortyp+1
        endif
        do k=1,2
          mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
        enddo
C Vectors and matrices dependent on a single virtual-bond dihedral.
        call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
        call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2)) 
        call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2)) 
        call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
        call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
        call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
        call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
        call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
        call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
      enddo
C Matrices dependent on two consecutive virtual-bond dihedrals.
C The order of matrices is from left to right.
      do i=2,nres-1
        call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
        call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
        call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
        call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
        call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
        call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
        call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
        call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
      enddo
cd      do i=1,nres
cd        iti = itortyp(itype(i))
cd        write (iout,*) i
cd        do j=1,2
cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)') 
cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
cd        enddo
cd      enddo
      return
      end
C--------------------------------------------------------------------------
      subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
C
C This subroutine calculates the average interaction energy and its gradient
C in the virtual-bond vectors between non-adjacent peptide groups, based on 
C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715. 
C The potential depends both on the distance of peptide-group centers and on 
C the orientation of the CA-CA virtual bonds.
C 
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.CONTROL'
      include 'COMMON.IOUNITS'
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.TORSION'
      include 'COMMON.VECTORS'
      include 'COMMON.FFIELD'
      include 'COMMON.SHIELD'

      dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
     &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
      double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
     &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
      double precision scal_el /0.5d0/
C 12/13/98 
C 13-go grudnia roku pamietnego... 
      double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
     &                   0.0d0,1.0d0,0.0d0,
     &                   0.0d0,0.0d0,1.0d0/
cd      write(iout,*) 'In EELEC'
cd      do i=1,nloctyp
cd        write(iout,*) 'Type',i
cd        write(iout,*) 'B1',B1(:,i)
cd        write(iout,*) 'B2',B2(:,i)
cd        write(iout,*) 'CC',CC(:,:,i)
cd        write(iout,*) 'DD',DD(:,:,i)
cd        write(iout,*) 'EE',EE(:,:,i)
cd      enddo
cd      call check_vecgrad
cd      stop
      if (icheckgrad.eq.1) then
        do i=1,nres-1
          fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
          do k=1,3
            dc_norm(k,i)=dc(k,i)*fac
          enddo
c          write (iout,*) 'i',i,' fac',fac
        enddo
      endif
      if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 
     &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. 
     &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
cd      if (wel_loc.gt.0.0d0) then
        if (icheckgrad.eq.1) then
        call vec_and_deriv_test
        else
        call vec_and_deriv
        endif
        call set_matrices
      endif
cd      do i=1,nres-1
cd        write (iout,*) 'i=',i
cd        do k=1,3
cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
cd        enddo
cd        do k=1,3
cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)') 
cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
cd        enddo
cd      enddo
      num_conti_hb=0
      ees=0.0D0
      evdw1=0.0D0
      eel_loc=0.0d0 
      eello_turn3=0.0d0
      eello_turn4=0.0d0
      ind=0
      do i=1,nres
        num_cont_hb(i)=0
      enddo
cd      print '(a)','Enter EELEC'
cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
      do i=1,nres
        gel_loc_loc(i)=0.0d0
        gcorr_loc(i)=0.0d0
      enddo
      do i=iatel_s,iatel_e
cAna           if (i.le.1) cycle
           if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
cAna     &  .or. ((i+2).gt.nres)
cAna     &  .or. ((i-1).le.0)
cAna     &  .or. itype(i+2).eq.ntyp1
cAna     &  .or. itype(i-1).eq.ntyp1
     &) cycle
C         endif
        if (itel(i).eq.0) goto 1215
        dxi=dc(1,i)
        dyi=dc(2,i)
        dzi=dc(3,i)
        dx_normi=dc_norm(1,i)
        dy_normi=dc_norm(2,i)
        dz_normi=dc_norm(3,i)
        xmedi=c(1,i)+0.5d0*dxi
        ymedi=c(2,i)+0.5d0*dyi
        zmedi=c(3,i)+0.5d0*dzi
          xmedi=mod(xmedi,boxxsize)
          if (xmedi.lt.0) xmedi=xmedi+boxxsize
          ymedi=mod(ymedi,boxysize)
          if (ymedi.lt.0) ymedi=ymedi+boxysize
          zmedi=mod(zmedi,boxzsize)
          if (zmedi.lt.0) zmedi=zmedi+boxzsize
        num_conti=0
c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
        do j=ielstart(i),ielend(i)
cAna          if (j.le.1) cycle
          if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
cAna     & .or.((j+2).gt.nres)
cAna     & .or.((j-1).le.0)
cAna     & .or.itype(j+2).eq.ntyp1
cAna     & .or.itype(j-1).eq.ntyp1
     &) cycle
C         endif
          if (itel(j).eq.0) goto 1216
          ind=ind+1
          iteli=itel(i)
          itelj=itel(j)
          if (j.eq.i+2 .and. itelj.eq.2) iteli=2
          aaa=app(iteli,itelj)
          bbb=bpp(iteli,itelj)
C Diagnostics only!!!
c         aaa=0.0D0
c         bbb=0.0D0
c         ael6i=0.0D0
c         ael3i=0.0D0
C End diagnostics
          ael6i=ael6(iteli,itelj)
          ael3i=ael3(iteli,itelj) 
          dxj=dc(1,j)
          dyj=dc(2,j)
          dzj=dc(3,j)
          dx_normj=dc_norm(1,j)
          dy_normj=dc_norm(2,j)
          dz_normj=dc_norm(3,j)
          xj=c(1,j)+0.5D0*dxj
          yj=c(2,j)+0.5D0*dyj
          zj=c(3,j)+0.5D0*dzj
         xj=mod(xj,boxxsize)
          if (xj.lt.0) xj=xj+boxxsize
          yj=mod(yj,boxysize)
          if (yj.lt.0) yj=yj+boxysize
          zj=mod(zj,boxzsize)
          if (zj.lt.0) zj=zj+boxzsize
      dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
      xj_safe=xj
      yj_safe=yj
      zj_safe=zj
      isubchap=0
      do xshift=-1,1
      do yshift=-1,1
      do zshift=-1,1
          xj=xj_safe+xshift*boxxsize
          yj=yj_safe+yshift*boxysize
          zj=zj_safe+zshift*boxzsize
          dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
          if(dist_temp.lt.dist_init) then
            dist_init=dist_temp
            xj_temp=xj
            yj_temp=yj
            zj_temp=zj
            isubchap=1
          endif
       enddo
       enddo
       enddo
       if (isubchap.eq.1) then
          xj=xj_temp-xmedi
          yj=yj_temp-ymedi
          zj=zj_temp-zmedi
       else
          xj=xj_safe-xmedi
          yj=yj_safe-ymedi
          zj=zj_safe-zmedi
       endif

          rij=xj*xj+yj*yj+zj*zj
            sss=sscale(sqrt(rij))
            sssgrad=sscagrad(sqrt(rij))
          rrmij=1.0D0/rij
          rij=dsqrt(rij)
          rmij=1.0D0/rij
          r3ij=rrmij*rmij
          r6ij=r3ij*r3ij  
          cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
          cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
          cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
          fac=cosa-3.0D0*cosb*cosg
          ev1=aaa*r6ij*r6ij
c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
          if (j.eq.i+2) ev1=scal_el*ev1
          ev2=bbb*r6ij
          fac3=ael6i*r6ij
          fac4=ael3i*r3ij
          evdwij=ev1+ev2
          el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
          el2=fac4*fac       
          eesij=el1+el2
c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
C 12/26/95 - for the evaluation of multi-body H-bonding interactions
          ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
          if (shield_mode.gt.0) then
C          fac_shield(i)=0.4
C          fac_shield(j)=0.6
C#define DEBUG
#ifdef DEBUG
          write(iout,*) "ees_compon",i,j,el1,el2,
     &    fac_shield(i),fac_shield(j)
#endif
C#undef DEBUG
          el1=el1*fac_shield(i)**2*fac_shield(j)**2
          el2=el2*fac_shield(i)**2*fac_shield(j)**2
          eesij=(el1+el2)
          ees=ees+eesij
          else
          fac_shield(i)=1.0
          fac_shield(j)=1.0
          eesij=(el1+el2)
          ees=ees+eesij
          endif
C          ees=ees+eesij
          evdw1=evdw1+evdwij*sss
cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
cd     &      xmedi,ymedi,zmedi,xj,yj,zj
C
C Calculate contributions to the Cartesian gradient.
C
#ifdef SPLITELE
          facvdw=-6*rrmij*(ev1+evdwij)*sss
          facel=-3*rrmij*(el1+eesij)
          fac1=fac
          erij(1)=xj*rmij
          erij(2)=yj*rmij
          erij(3)=zj*rmij
          if (calc_grad) then
*
* Radial derivatives. First process both termini of the fragment (i,j)
* 
          ggg(1)=facel*xj
          ggg(2)=facel*yj
          ggg(3)=facel*zj

          if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
     &  (shield_mode.gt.0)) then
C          print *,i,j     
          do ilist=1,ishield_list(i)
           iresshield=shield_list(ilist,i)
           do k=1,3
           rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
     &      *2.0
           gshieldx(k,iresshield)=gshieldx(k,iresshield)+
     &              rlocshield
     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
C             if (iresshield.gt.i) then
C               do ishi=i+1,iresshield-1
C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
C
C              enddo
C             else
C               do ishi=iresshield,i
C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
C
C               enddo
C              endif
C           enddo
C          enddo
           enddo
          enddo
          do ilist=1,ishield_list(j)
           iresshield=shield_list(ilist,j)
           do k=1,3
           rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
     &     *2.0
           gshieldx(k,iresshield)=gshieldx(k,iresshield)+
     &              rlocshield
     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
           gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
           enddo
          enddo

          do k=1,3
            gshieldc(k,i)=gshieldc(k,i)+
     &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
            gshieldc(k,j)=gshieldc(k,j)+
     &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
            gshieldc(k,i-1)=gshieldc(k,i-1)+
     &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
            gshieldc(k,j-1)=gshieldc(k,j-1)+
     &              grad_shield(k,j)*eesij/fac_shield(j)*2.0

           enddo
           endif

          do k=1,3
            ghalf=0.5D0*ggg(k)
            gelc(k,i)=gelc(k,i)+ghalf
            gelc(k,j)=gelc(k,j)+ghalf
          enddo
*
* Loop over residues i+1 thru j-1.
*
          do k=i+1,j-1
            do l=1,3
              gelc(l,k)=gelc(l,k)+ggg(l)
            enddo
          enddo
C          ggg(1)=facvdw*xj
C          ggg(2)=facvdw*yj
C          ggg(3)=facvdw*zj
          if (sss.gt.0.0) then
          ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
          ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
          ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
          else
          ggg(1)=0.0
          ggg(2)=0.0
          ggg(3)=0.0
          endif
          do k=1,3
            ghalf=0.5D0*ggg(k)
            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
          enddo
*
* Loop over residues i+1 thru j-1.
*
          do k=i+1,j-1
            do l=1,3
              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
            enddo
          enddo
#else
          facvdw=(ev1+evdwij)*sss
          facel=el1+eesij  
          fac1=fac
          fac=-3*rrmij*(facvdw+facvdw+facel)
          erij(1)=xj*rmij
          erij(2)=yj*rmij
          erij(3)=zj*rmij
          if (calc_grad) then
*
* Radial derivatives. First process both termini of the fragment (i,j)
* 
          ggg(1)=fac*xj
          ggg(2)=fac*yj
          ggg(3)=fac*zj
          do k=1,3
            ghalf=0.5D0*ggg(k)
            gelc(k,i)=gelc(k,i)+ghalf
            gelc(k,j)=gelc(k,j)+ghalf
          enddo
*
* Loop over residues i+1 thru j-1.
*
          do k=i+1,j-1
            do l=1,3
              gelc(l,k)=gelc(l,k)+ggg(l)
            enddo
          enddo
#endif
*
* Angular part
*          
          ecosa=2.0D0*fac3*fac1+fac4
          fac4=-3.0D0*fac4
          fac3=-6.0D0*fac3
          ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
          ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
          do k=1,3
            dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
            dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
          enddo
cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
cd   &          (dcosg(k),k=1,3)
          do k=1,3
            ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k) 
     &      *fac_shield(i)**2*fac_shield(j)**2
          enddo
          do k=1,3
            ghalf=0.5D0*ggg(k)
            gelc(k,i)=gelc(k,i)+ghalf
     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
     &           *fac_shield(i)**2*fac_shield(j)**2

            gelc(k,j)=gelc(k,j)+ghalf
     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
     &           *fac_shield(i)**2*fac_shield(j)**2
          enddo
          do k=i+1,j-1
            do l=1,3
              gelc(l,k)=gelc(l,k)+ggg(l)
            enddo
          enddo
          endif

          IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
     &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 
     &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
C
C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction 
C   energy of a peptide unit is assumed in the form of a second-order 
C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
C   are computed for EVERY pair of non-contiguous peptide groups.
C
          if (j.lt.nres-1) then
            j1=j+1
            j2=j-1
          else
            j1=j-1
            j2=j-2
          endif
          kkk=0
          do k=1,2
            do l=1,2
              kkk=kkk+1
              muij(kkk)=mu(k,i)*mu(l,j)
            enddo
          enddo  
cd         write (iout,*) 'EELEC: i',i,' j',j
cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
cd          write(iout,*) 'muij',muij
          ury=scalar(uy(1,i),erij)
          urz=scalar(uz(1,i),erij)
          vry=scalar(uy(1,j),erij)
          vrz=scalar(uz(1,j),erij)
          a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
          a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
          a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
          a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
C For diagnostics only
cd          a22=1.0d0
cd          a23=1.0d0
cd          a32=1.0d0
cd          a33=1.0d0
          fac=dsqrt(-ael6i)*r3ij
cd          write (2,*) 'fac=',fac
C For diagnostics only
cd          fac=1.0d0
          a22=a22*fac
          a23=a23*fac
          a32=a32*fac
          a33=a33*fac
cd          write (iout,'(4i5,4f10.5)')
cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
cd          write (iout,'(4f10.5)') 
cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
cd           write (iout,'(2i3,9f10.5/)') i,j,
cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
          if (calc_grad) then
C Derivatives of the elements of A in virtual-bond vectors
          call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
cd          do k=1,3
cd            do l=1,3
cd              erder(k,l)=0.0d0
cd            enddo
cd          enddo
          do k=1,3
            uryg(k,1)=scalar(erder(1,k),uy(1,i))
            uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
            uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
            urzg(k,1)=scalar(erder(1,k),uz(1,i))
            urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
            urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
            vryg(k,1)=scalar(erder(1,k),uy(1,j))
            vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
            vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
            vrzg(k,1)=scalar(erder(1,k),uz(1,j))
            vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
            vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
          enddo
cd          do k=1,3
cd            do l=1,3
cd              uryg(k,l)=0.0d0
cd              urzg(k,l)=0.0d0
cd              vryg(k,l)=0.0d0
cd              vrzg(k,l)=0.0d0
cd            enddo
cd          enddo
C Compute radial contributions to the gradient
          facr=-3.0d0*rrmij
          a22der=a22*facr
          a23der=a23*facr
          a32der=a32*facr
          a33der=a33*facr
cd          a22der=0.0d0
cd          a23der=0.0d0
cd          a32der=0.0d0
cd          a33der=0.0d0
          agg(1,1)=a22der*xj
          agg(2,1)=a22der*yj
          agg(3,1)=a22der*zj
          agg(1,2)=a23der*xj
          agg(2,2)=a23der*yj
          agg(3,2)=a23der*zj
          agg(1,3)=a32der*xj
          agg(2,3)=a32der*yj
          agg(3,3)=a32der*zj
          agg(1,4)=a33der*xj
          agg(2,4)=a33der*yj
          agg(3,4)=a33der*zj
C Add the contributions coming from er
          fac3=-3.0d0*fac
          do k=1,3
            agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
            agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
            agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
            agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
          enddo
          do k=1,3
C Derivatives in DC(i) 
            ghalf1=0.5d0*agg(k,1)
            ghalf2=0.5d0*agg(k,2)
            ghalf3=0.5d0*agg(k,3)
            ghalf4=0.5d0*agg(k,4)
            aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
     &      -3.0d0*uryg(k,2)*vry)+ghalf1
            aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
     &      -3.0d0*uryg(k,2)*vrz)+ghalf2
            aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
     &      -3.0d0*urzg(k,2)*vry)+ghalf3
            aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
     &      -3.0d0*urzg(k,2)*vrz)+ghalf4
C Derivatives in DC(i+1)
            aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
     &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
            aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
     &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
            aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
     &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
            aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
     &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
C Derivatives in DC(j)
            aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
     &      -3.0d0*vryg(k,2)*ury)+ghalf1
            aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
     &      -3.0d0*vrzg(k,2)*ury)+ghalf2
            aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
     &      -3.0d0*vryg(k,2)*urz)+ghalf3
            aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) 
     &      -3.0d0*vrzg(k,2)*urz)+ghalf4
C Derivatives in DC(j+1) or DC(nres-1)
            aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
     &      -3.0d0*vryg(k,3)*ury)
            aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
     &      -3.0d0*vrzg(k,3)*ury)
            aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
     &      -3.0d0*vryg(k,3)*urz)
            aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) 
     &      -3.0d0*vrzg(k,3)*urz)
cd            aggi(k,1)=ghalf1
cd            aggi(k,2)=ghalf2
cd            aggi(k,3)=ghalf3
cd            aggi(k,4)=ghalf4
C Derivatives in DC(i+1)
cd            aggi1(k,1)=agg(k,1)
cd            aggi1(k,2)=agg(k,2)
cd            aggi1(k,3)=agg(k,3)
cd            aggi1(k,4)=agg(k,4)
C Derivatives in DC(j)
cd            aggj(k,1)=ghalf1
cd            aggj(k,2)=ghalf2
cd            aggj(k,3)=ghalf3
cd            aggj(k,4)=ghalf4
C Derivatives in DC(j+1)
cd            aggj1(k,1)=0.0d0
cd            aggj1(k,2)=0.0d0
cd            aggj1(k,3)=0.0d0
cd            aggj1(k,4)=0.0d0
            if (j.eq.nres-1 .and. i.lt.j-2) then
              do l=1,4
                aggj1(k,l)=aggj1(k,l)+agg(k,l)
cd                aggj1(k,l)=agg(k,l)
              enddo
            endif
          enddo
          endif
c          goto 11111
C Check the loc-el terms by numerical integration
          acipa(1,1)=a22
          acipa(1,2)=a23
          acipa(2,1)=a32
          acipa(2,2)=a33
          a22=-a22
          a23=-a23
          do l=1,2
            do k=1,3
              agg(k,l)=-agg(k,l)
              aggi(k,l)=-aggi(k,l)
              aggi1(k,l)=-aggi1(k,l)
              aggj(k,l)=-aggj(k,l)
              aggj1(k,l)=-aggj1(k,l)
            enddo
          enddo
          if (j.lt.nres-1) then
            a22=-a22
            a32=-a32
            do l=1,3,2
              do k=1,3
                agg(k,l)=-agg(k,l)
                aggi(k,l)=-aggi(k,l)
                aggi1(k,l)=-aggi1(k,l)
                aggj(k,l)=-aggj(k,l)
                aggj1(k,l)=-aggj1(k,l)
              enddo
            enddo
          else
            a22=-a22
            a23=-a23
            a32=-a32
            a33=-a33
            do l=1,4
              do k=1,3
                agg(k,l)=-agg(k,l)
                aggi(k,l)=-aggi(k,l)
                aggi1(k,l)=-aggi1(k,l)
                aggj(k,l)=-aggj(k,l)
                aggj1(k,l)=-aggj1(k,l)
              enddo
            enddo 
          endif    
          ENDIF ! WCORR
11111     continue
          IF (wel_loc.gt.0.0d0) THEN
C Contribution to the local-electrostatic energy coming from the i-j pair
          eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
     &     +a33*muij(4)
cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
          if (shield_mode.eq.0) then
           fac_shield(i)=1.0
           fac_shield(j)=1.0
C          else
C           fac_shield(i)=0.4
C           fac_shield(j)=0.6
          endif
          eel_loc_ij=eel_loc_ij
     &    *fac_shield(i)*fac_shield(j)
          eel_loc=eel_loc+eel_loc_ij
C Partial derivatives in virtual-bond dihedral angles gamma
          if (calc_grad) then
          if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
     &  (shield_mode.gt.0)) then
C          print *,i,j     

          do ilist=1,ishield_list(i)
           iresshield=shield_list(ilist,i)
           do k=1,3
           rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
     &                                          /fac_shield(i)
C     &      *2.0
           gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
     &              rlocshield
     & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
     &      +rlocshield
           enddo
          enddo
          do ilist=1,ishield_list(j)
           iresshield=shield_list(ilist,j)
           do k=1,3
           rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
     &                                       /fac_shield(j)
C     &     *2.0
           gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
     &              rlocshield
     & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
           gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
     &             +rlocshield

           enddo
          enddo
          do k=1,3
            gshieldc_ll(k,i)=gshieldc_ll(k,i)+
     &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
            gshieldc_ll(k,j)=gshieldc_ll(k,j)+
     &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
            gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
     &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
            gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
     &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
           enddo
           endif
          if (i.gt.1)
     &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+ 
     &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
     &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
     &    *fac_shield(i)*fac_shield(j)
          gel_loc_loc(j-1)=gel_loc_loc(j-1)+ 
     &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
     &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
     &    *fac_shield(i)*fac_shield(j)

cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
cd          write(iout,*) 'agg  ',agg
cd          write(iout,*) 'aggi ',aggi
cd          write(iout,*) 'aggi1',aggi1
cd          write(iout,*) 'aggj ',aggj
cd          write(iout,*) 'aggj1',aggj1

C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
          do l=1,3
            ggg(l)=agg(l,1)*muij(1)+
     &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
     &    *fac_shield(i)*fac_shield(j)

          enddo
          do k=i+2,j2
            do l=1,3
              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
            enddo
          enddo
C Remaining derivatives of eello
          do l=1,3
            gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
     &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
     &    *fac_shield(i)*fac_shield(j)

            gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
     &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
     &    *fac_shield(i)*fac_shield(j)

            gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
     &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
     &    *fac_shield(i)*fac_shield(j)

            gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
     &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
     &    *fac_shield(i)*fac_shield(j)

          enddo
          endif
          ENDIF
          if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
C Contributions from turns
            a_temp(1,1)=a22
            a_temp(1,2)=a23
            a_temp(2,1)=a32
            a_temp(2,2)=a33
            call eturn34(i,j,eello_turn3,eello_turn4)
          endif
C Change 12/26/95 to calculate four-body contributions to H-bonding energy
          if (j.gt.i+1 .and. num_conti.le.maxconts) then
C
C Calculate the contact function. The ith column of the array JCONT will 
C contain the numbers of atoms that make contacts with the atom I (of numbers
C greater than I). The arrays FACONT and GACONT will contain the values of
C the contact function and its derivative.
c           r0ij=1.02D0*rpp(iteli,itelj)
c           r0ij=1.11D0*rpp(iteli,itelj)
            r0ij=2.20D0*rpp(iteli,itelj)
c           r0ij=1.55D0*rpp(iteli,itelj)
            call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
            if (fcont.gt.0.0D0) then
              num_conti=num_conti+1
              if (num_conti.gt.maxconts) then
                write (iout,*) 'WARNING - max. # of contacts exceeded;',
     &                         ' will skip next contacts for this conf.'
              else
                jcont_hb(num_conti,i)=j
                IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. 
     &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
C  terms.
                d_cont(num_conti,i)=rij
cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
C     --- Electrostatic-interaction matrix --- 
                a_chuj(1,1,num_conti,i)=a22
                a_chuj(1,2,num_conti,i)=a23
                a_chuj(2,1,num_conti,i)=a32
                a_chuj(2,2,num_conti,i)=a33
C     --- Gradient of rij
                do kkk=1,3
                  grij_hb_cont(kkk,num_conti,i)=erij(kkk)
                enddo
c             if (i.eq.1) then
c                a_chuj(1,1,num_conti,i)=-0.61d0
c                a_chuj(1,2,num_conti,i)= 0.4d0
c                a_chuj(2,1,num_conti,i)= 0.65d0
c                a_chuj(2,2,num_conti,i)= 0.50d0
c             else if (i.eq.2) then
c                a_chuj(1,1,num_conti,i)= 0.0d0
c                a_chuj(1,2,num_conti,i)= 0.0d0
c                a_chuj(2,1,num_conti,i)= 0.0d0
c                a_chuj(2,2,num_conti,i)= 0.0d0
c             endif
C     --- and its gradients
cd                write (iout,*) 'i',i,' j',j
cd                do kkk=1,3
cd                write (iout,*) 'iii 1 kkk',kkk
cd                write (iout,*) agg(kkk,:)
cd                enddo
cd                do kkk=1,3
cd                write (iout,*) 'iii 2 kkk',kkk
cd                write (iout,*) aggi(kkk,:)
cd                enddo
cd                do kkk=1,3
cd                write (iout,*) 'iii 3 kkk',kkk
cd                write (iout,*) aggi1(kkk,:)
cd                enddo
cd                do kkk=1,3
cd                write (iout,*) 'iii 4 kkk',kkk
cd                write (iout,*) aggj(kkk,:)
cd                enddo
cd                do kkk=1,3
cd                write (iout,*) 'iii 5 kkk',kkk
cd                write (iout,*) aggj1(kkk,:)
cd                enddo
                kkll=0
                do k=1,2
                  do l=1,2
                    kkll=kkll+1
                    do m=1,3
                      a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
                      a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
                      a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
                      a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
                      a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
c                      do mm=1,5
c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
c                      enddo
                    enddo
                  enddo
                enddo
                ENDIF
                IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
C Calculate contact energies
                cosa4=4.0D0*cosa
                wij=cosa-3.0D0*cosb*cosg
                cosbg1=cosb+cosg
                cosbg2=cosb-cosg
c               fac3=dsqrt(-ael6i)/r0ij**3     
                fac3=dsqrt(-ael6i)*r3ij
                ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
                if (shield_mode.eq.0) then
                fac_shield(i)=1.0d0
                fac_shield(j)=1.0d0
                else
                ees0plist(num_conti,i)=j
C                fac_shield(i)=0.4d0
C                fac_shield(j)=0.6d0
                endif
c               ees0mij=0.0D0
                ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
     &          *fac_shield(i)*fac_shield(j)

                ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
     &          *fac_shield(i)*fac_shield(j)

C Diagnostics. Comment out or remove after debugging!
c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
c               ees0m(num_conti,i)=0.0D0
C End diagnostics.
c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
                facont_hb(num_conti,i)=fcont
                if (calc_grad) then
C Angular derivatives of the contact function
                ees0pij1=fac3/ees0pij 
                ees0mij1=fac3/ees0mij
                fac3p=-3.0D0*fac3*rrmij
                ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
                ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
c               ees0mij1=0.0D0
                ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
                ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
                ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
                ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
                ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) 
                ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
                ecosap=ecosa1+ecosa2
                ecosbp=ecosb1+ecosb2
                ecosgp=ecosg1+ecosg2
                ecosam=ecosa1-ecosa2
                ecosbm=ecosb1-ecosb2
                ecosgm=ecosg1-ecosg2
C Diagnostics
c               ecosap=ecosa1
c               ecosbp=ecosb1
c               ecosgp=ecosg1
c               ecosam=0.0D0
c               ecosbm=0.0D0
c               ecosgm=0.0D0
C End diagnostics
                fprimcont=fprimcont/rij
cd              facont_hb(num_conti,i)=1.0D0
C Following line is for diagnostics.
cd              fprimcont=0.0D0
                do k=1,3
                  dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
                  dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
                enddo
                do k=1,3
                  gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
                  gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
                enddo
                gggp(1)=gggp(1)+ees0pijp*xj
                gggp(2)=gggp(2)+ees0pijp*yj
                gggp(3)=gggp(3)+ees0pijp*zj
                gggm(1)=gggm(1)+ees0mijp*xj
                gggm(2)=gggm(2)+ees0mijp*yj
                gggm(3)=gggm(3)+ees0mijp*zj
C Derivatives due to the contact function
                gacont_hbr(1,num_conti,i)=fprimcont*xj
                gacont_hbr(2,num_conti,i)=fprimcont*yj
                gacont_hbr(3,num_conti,i)=fprimcont*zj
                do k=1,3
                  ghalfp=0.5D0*gggp(k)
                  ghalfm=0.5D0*gggm(k)
                  gacontp_hb1(k,num_conti,i)=ghalfp
     &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
     &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
     &          *fac_shield(i)*fac_shield(j)

                  gacontp_hb2(k,num_conti,i)=ghalfp
     &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
     &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
     &          *fac_shield(i)*fac_shield(j)

                  gacontp_hb3(k,num_conti,i)=gggp(k)
     &          *fac_shield(i)*fac_shield(j)

                  gacontm_hb1(k,num_conti,i)=ghalfm
     &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
     &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
     &          *fac_shield(i)*fac_shield(j)

                  gacontm_hb2(k,num_conti,i)=ghalfm
     &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
     &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
     &          *fac_shield(i)*fac_shield(j)

                  gacontm_hb3(k,num_conti,i)=gggm(k)
     &          *fac_shield(i)*fac_shield(j)

                enddo
                endif
C Diagnostics. Comment out or remove after debugging!
cdiag           do k=1,3
cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
cdiag           enddo
              ENDIF ! wcorr
              endif  ! num_conti.le.maxconts
            endif  ! fcont.gt.0
          endif    ! j.gt.i+1
 1216     continue
        enddo ! j
        num_cont_hb(i)=num_conti
 1215   continue
      enddo   ! i
cd      do i=1,nres
cd        write (iout,'(i3,3f10.5,5x,3f10.5)') 
cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
cd      enddo
c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
ccc      eel_loc=eel_loc+eello_turn3
      return
      end
C-----------------------------------------------------------------------------
      subroutine eturn34(i,j,eello_turn3,eello_turn4)
C Third- and fourth-order contributions from turns
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.TORSION'
      include 'COMMON.VECTORS'
      include 'COMMON.FFIELD'
      include 'COMMON.SHIELD'
      include 'COMMON.CONTROL'

      dimension ggg(3)
      double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
     &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
     &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
      double precision agg(3,4),aggi(3,4),aggi1(3,4),
     &    aggj(3,4),aggj1(3,4),a_temp(2,2)
      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
      if (j.eq.i+2) then
      if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
C changes suggested by Ana to avoid out of bounds
C     & .or.((i+5).gt.nres)
C     & .or.((i-1).le.0)
C end of changes suggested by Ana
     &    .or. itype(i+2).eq.ntyp1
     &    .or. itype(i+3).eq.ntyp1
C     &    .or. itype(i+5).eq.ntyp1
C     &    .or. itype(i).eq.ntyp1
C     &    .or. itype(i-1).eq.ntyp1
     &    ) goto 179

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C               Third-order contributions
C        
C                 (i+2)o----(i+3)
C                      | |
C                      | |
C                 (i+1)o----i
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC   
cd        call checkint_turn3(i,a_temp,eello_turn3_num)
        call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
        call transpose2(auxmat(1,1),auxmat1(1,1))
        call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
        if (shield_mode.eq.0) then
        fac_shield(i)=1.0
        fac_shield(j)=1.0
C        else
C        fac_shield(i)=0.4
C        fac_shield(j)=0.6
        endif
        eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
     &  *fac_shield(i)*fac_shield(j)
        eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
     &  *fac_shield(i)*fac_shield(j)

cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
cd     &    ' eello_turn3_num',4*eello_turn3_num
        if (calc_grad) then
C Derivatives in shield mode
          if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
     &  (shield_mode.gt.0)) then
C          print *,i,j     

          do ilist=1,ishield_list(i)
           iresshield=shield_list(ilist,i)
           do k=1,3
           rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
C     &      *2.0
           gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
     &              rlocshield
     & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
     &      +rlocshield
           enddo
          enddo
          do ilist=1,ishield_list(j)
           iresshield=shield_list(ilist,j)
           do k=1,3
           rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
C     &     *2.0
           gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
     &              rlocshield
     & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
           gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
     &             +rlocshield

           enddo
          enddo

          do k=1,3
            gshieldc_t3(k,i)=gshieldc_t3(k,i)+
     &              grad_shield(k,i)*eello_t3/fac_shield(i)
            gshieldc_t3(k,j)=gshieldc_t3(k,j)+
     &              grad_shield(k,j)*eello_t3/fac_shield(j)
            gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
     &              grad_shield(k,i)*eello_t3/fac_shield(i)
            gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
     &              grad_shield(k,j)*eello_t3/fac_shield(j)
           enddo
           endif

C Derivatives in gamma(i)
        call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
        call transpose2(auxmat2(1,1),pizda(1,1))
        call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
        gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
     &   *fac_shield(i)*fac_shield(j)

C Derivatives in gamma(i+1)
        call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
        call transpose2(auxmat2(1,1),pizda(1,1))
        call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
        gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
     &    +0.5d0*(pizda(1,1)+pizda(2,2))
     &   *fac_shield(i)*fac_shield(j)

C Cartesian derivatives
        do l=1,3
          a_temp(1,1)=aggi(l,1)
          a_temp(1,2)=aggi(l,2)
          a_temp(2,1)=aggi(l,3)
          a_temp(2,2)=aggi(l,4)
          call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
          gcorr3_turn(l,i)=gcorr3_turn(l,i)
     &      +0.5d0*(pizda(1,1)+pizda(2,2))
     &   *fac_shield(i)*fac_shield(j)

          a_temp(1,1)=aggi1(l,1)
          a_temp(1,2)=aggi1(l,2)
          a_temp(2,1)=aggi1(l,3)
          a_temp(2,2)=aggi1(l,4)
          call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
          gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
     &      +0.5d0*(pizda(1,1)+pizda(2,2))
     &   *fac_shield(i)*fac_shield(j)

          a_temp(1,1)=aggj(l,1)
          a_temp(1,2)=aggj(l,2)
          a_temp(2,1)=aggj(l,3)
          a_temp(2,2)=aggj(l,4)
          call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
          gcorr3_turn(l,j)=gcorr3_turn(l,j)
     &      +0.5d0*(pizda(1,1)+pizda(2,2))
     &   *fac_shield(i)*fac_shield(j)

          a_temp(1,1)=aggj1(l,1)
          a_temp(1,2)=aggj1(l,2)
          a_temp(2,1)=aggj1(l,3)
          a_temp(2,2)=aggj1(l,4)
          call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
          gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
     &      +0.5d0*(pizda(1,1)+pizda(2,2))
     &   *fac_shield(i)*fac_shield(j)

        enddo
        endif
  179 continue
      else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
      if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
C changes suggested by Ana to avoid out of bounds
C     & .or.((i+5).gt.nres)
C     & .or.((i-1).le.0)
C end of changes suggested by Ana
     &    .or. itype(i+3).eq.ntyp1
     &    .or. itype(i+4).eq.ntyp1
C     &    .or. itype(i+5).eq.ntyp1
     &    .or. itype(i).eq.ntyp1
C     &    .or. itype(i-1).eq.ntyp1
     &    ) goto 178

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C               Fourth-order contributions
C        
C                 (i+3)o----(i+4)
C                     /  |
C               (i+2)o   |
C                     \  |
C                 (i+1)o----i
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC   
cd        call checkint_turn4(i,a_temp,eello_turn4_num)
        iti1=itortyp(itype(i+1))
        iti2=itortyp(itype(i+2))
        iti3=itortyp(itype(i+3))
        call transpose2(EUg(1,1,i+1),e1t(1,1))
        call transpose2(Eug(1,1,i+2),e2t(1,1))
        call transpose2(Eug(1,1,i+3),e3t(1,1))
        call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
        call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
        s1=scalar2(b1(1,iti2),auxvec(1))
        call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
        call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) 
        s2=scalar2(b1(1,iti1),auxvec(1))
        call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
        call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
        s3=0.5d0*(pizda(1,1)+pizda(2,2))
        if (shield_mode.eq.0) then
        fac_shield(i)=1.0
        fac_shield(j)=1.0
C        else
C        fac_shield(i)=0.4
C        fac_shield(j)=0.6
        endif
        eello_turn4=eello_turn4-(s1+s2+s3)
     &  *fac_shield(i)*fac_shield(j)
        eello_t4=-(s1+s2+s3)
     &  *fac_shield(i)*fac_shield(j)

cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
cd     &    ' eello_turn4_num',8*eello_turn4_num
C Derivatives in gamma(i)
        if (calc_grad) then
          if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
     &  (shield_mode.gt.0)) then
C          print *,i,j     

          do ilist=1,ishield_list(i)
           iresshield=shield_list(ilist,i)
           do k=1,3
           rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
C     &      *2.0
           gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
     &              rlocshield
     & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
     &      +rlocshield
           enddo
          enddo
          do ilist=1,ishield_list(j)
           iresshield=shield_list(ilist,j)
           do k=1,3
           rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
C     &     *2.0
           gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
     &              rlocshield
     & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
           gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
     &             +rlocshield

           enddo
          enddo

          do k=1,3
            gshieldc_t4(k,i)=gshieldc_t4(k,i)+
     &              grad_shield(k,i)*eello_t4/fac_shield(i)
            gshieldc_t4(k,j)=gshieldc_t4(k,j)+
     &              grad_shield(k,j)*eello_t4/fac_shield(j)
            gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
     &              grad_shield(k,i)*eello_t4/fac_shield(i)
            gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
     &              grad_shield(k,j)*eello_t4/fac_shield(j)
           enddo
           endif

        call transpose2(EUgder(1,1,i+1),e1tder(1,1))
        call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
        call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
        s1=scalar2(b1(1,iti2),auxvec(1))
        call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
        s3=0.5d0*(pizda(1,1)+pizda(2,2))
        gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
     &  *fac_shield(i)*fac_shield(j)

C Derivatives in gamma(i+1)
        call transpose2(EUgder(1,1,i+2),e2tder(1,1))
        call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1)) 
        s2=scalar2(b1(1,iti1),auxvec(1))
        call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
        call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
        s3=0.5d0*(pizda(1,1)+pizda(2,2))
        gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
     &  *fac_shield(i)*fac_shield(j)

C Derivatives in gamma(i+2)
        call transpose2(EUgder(1,1,i+3),e3tder(1,1))
        call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
        s1=scalar2(b1(1,iti2),auxvec(1))
        call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
        call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1)) 
        s2=scalar2(b1(1,iti1),auxvec(1))
        call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
        call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
        s3=0.5d0*(pizda(1,1)+pizda(2,2))
        gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
     &  *fac_shield(i)*fac_shield(j)

C Cartesian derivatives
C Derivatives of this turn contributions in DC(i+2)
        if (j.lt.nres-1) then
          do l=1,3
            a_temp(1,1)=agg(l,1)
            a_temp(1,2)=agg(l,2)
            a_temp(2,1)=agg(l,3)
            a_temp(2,2)=agg(l,4)
            call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
            call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
            s1=scalar2(b1(1,iti2),auxvec(1))
            call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
            call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) 
            s2=scalar2(b1(1,iti1),auxvec(1))
            call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
            call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
            s3=0.5d0*(pizda(1,1)+pizda(2,2))
            ggg(l)=-(s1+s2+s3)
            gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
     &  *fac_shield(i)*fac_shield(j)

          enddo
        endif
C Remaining derivatives of this turn contribution
        do l=1,3
          a_temp(1,1)=aggi(l,1)
          a_temp(1,2)=aggi(l,2)
          a_temp(2,1)=aggi(l,3)
          a_temp(2,2)=aggi(l,4)
          call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
          call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
          s1=scalar2(b1(1,iti2),auxvec(1))
          call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
          call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) 
          s2=scalar2(b1(1,iti1),auxvec(1))
          call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
          call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
          s3=0.5d0*(pizda(1,1)+pizda(2,2))
          gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
     &  *fac_shield(i)*fac_shield(j)

          a_temp(1,1)=aggi1(l,1)
          a_temp(1,2)=aggi1(l,2)
          a_temp(2,1)=aggi1(l,3)
          a_temp(2,2)=aggi1(l,4)
          call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
          call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
          s1=scalar2(b1(1,iti2),auxvec(1))
          call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
          call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) 
          s2=scalar2(b1(1,iti1),auxvec(1))
          call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
          call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
          s3=0.5d0*(pizda(1,1)+pizda(2,2))
          gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
     &  *fac_shield(i)*fac_shield(j)

          a_temp(1,1)=aggj(l,1)
          a_temp(1,2)=aggj(l,2)
          a_temp(2,1)=aggj(l,3)
          a_temp(2,2)=aggj(l,4)
          call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
          call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
          s1=scalar2(b1(1,iti2),auxvec(1))
          call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
          call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) 
          s2=scalar2(b1(1,iti1),auxvec(1))
          call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
          call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
          s3=0.5d0*(pizda(1,1)+pizda(2,2))
          gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
     &  *fac_shield(i)*fac_shield(j)

          a_temp(1,1)=aggj1(l,1)
          a_temp(1,2)=aggj1(l,2)
          a_temp(2,1)=aggj1(l,3)
          a_temp(2,2)=aggj1(l,4)
          call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
          call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
          s1=scalar2(b1(1,iti2),auxvec(1))
          call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
          call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) 
          s2=scalar2(b1(1,iti1),auxvec(1))
          call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
          call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
          s3=0.5d0*(pizda(1,1)+pizda(2,2))
          gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
     &  *fac_shield(i)*fac_shield(j)

        enddo
        endif
  178 continue
      endif          
      return
      end
C-----------------------------------------------------------------------------
      subroutine vecpr(u,v,w)
      implicit real*8(a-h,o-z)
      dimension u(3),v(3),w(3)
      w(1)=u(2)*v(3)-u(3)*v(2)
      w(2)=-u(1)*v(3)+u(3)*v(1)
      w(3)=u(1)*v(2)-u(2)*v(1)
      return
      end
C-----------------------------------------------------------------------------
      subroutine unormderiv(u,ugrad,unorm,ungrad)
C This subroutine computes the derivatives of a normalized vector u, given
C the derivatives computed without normalization conditions, ugrad. Returns
C ungrad.
      implicit none
      double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
      double precision vec(3)
      double precision scalar
      integer i,j
c      write (2,*) 'ugrad',ugrad
c      write (2,*) 'u',u
      do i=1,3
        vec(i)=scalar(ugrad(1,i),u(1))
      enddo
c      write (2,*) 'vec',vec
      do i=1,3
        do j=1,3
          ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
        enddo
      enddo
c      write (2,*) 'ungrad',ungrad
      return
      end
C-----------------------------------------------------------------------------
      subroutine escp(evdw2,evdw2_14)
C
C This subroutine calculates the excluded-volume interaction energy between
C peptide-group centers and side chains and its gradient in virtual-bond and
C side-chain vectors.
C
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.FFIELD'
      include 'COMMON.IOUNITS'
      dimension ggg(3)
      evdw2=0.0D0
      evdw2_14=0.0d0
cd    print '(a)','Enter ESCP'
c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
c     &  ' scal14',scal14
      do i=iatscp_s,iatscp_e
        if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
        iteli=itel(i)
c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
        if (iteli.eq.0) goto 1225
        xi=0.5D0*(c(1,i)+c(1,i+1))
        yi=0.5D0*(c(2,i)+c(2,i+1))
        zi=0.5D0*(c(3,i)+c(3,i+1))
C    Returning the ith atom to box
          xi=mod(xi,boxxsize)
          if (xi.lt.0) xi=xi+boxxsize
          yi=mod(yi,boxysize)
          if (yi.lt.0) yi=yi+boxysize
          zi=mod(zi,boxzsize)
          if (zi.lt.0) zi=zi+boxzsize

        do iint=1,nscp_gr(i)

        do j=iscpstart(i,iint),iscpend(i,iint)
          itypj=iabs(itype(j))
          if (itypj.eq.ntyp1) cycle
C Uncomment following three lines for SC-p interactions
c         xj=c(1,nres+j)-xi
c         yj=c(2,nres+j)-yi
c         zj=c(3,nres+j)-zi
C Uncomment following three lines for Ca-p interactions
          xj=c(1,j)
          yj=c(2,j)
          zj=c(3,j)
C returning the jth atom to box
          xj=mod(xj,boxxsize)
          if (xj.lt.0) xj=xj+boxxsize
          yj=mod(yj,boxysize)
          if (yj.lt.0) yj=yj+boxysize
          zj=mod(zj,boxzsize)
          if (zj.lt.0) zj=zj+boxzsize
      dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
      xj_safe=xj
      yj_safe=yj
      zj_safe=zj
      subchap=0
C Finding the closest jth atom
      do xshift=-1,1
      do yshift=-1,1
      do zshift=-1,1
          xj=xj_safe+xshift*boxxsize
          yj=yj_safe+yshift*boxysize
          zj=zj_safe+zshift*boxzsize
          dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
          if(dist_temp.lt.dist_init) then
            dist_init=dist_temp
            xj_temp=xj
            yj_temp=yj
            zj_temp=zj
            subchap=1
          endif
       enddo
       enddo
       enddo
       if (subchap.eq.1) then
          xj=xj_temp-xi
          yj=yj_temp-yi
          zj=zj_temp-zi
       else
          xj=xj_safe-xi
          yj=yj_safe-yi
          zj=zj_safe-zi
       endif

          rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
C sss is scaling function for smoothing the cutoff gradient otherwise
C the gradient would not be continuouse
          sss=sscale(1.0d0/(dsqrt(rrij)))
          if (sss.le.0.0d0) cycle
          sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
          fac=rrij**expon2
          e1=fac*fac*aad(itypj,iteli)
          e2=fac*bad(itypj,iteli)
          if (iabs(j-i) .le. 2) then
            e1=scal14*e1
            e2=scal14*e2
            evdw2_14=evdw2_14+(e1+e2)*sss
          endif
          evdwij=e1+e2
c          write (iout,*) i,j,evdwij
          evdw2=evdw2+evdwij*sss
          if (calc_grad) then
C
C Calculate contributions to the gradient in the virtual-bond and SC vectors.
C
           fac=-(evdwij+e1)*rrij*sss
           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
          ggg(1)=xj*fac
          ggg(2)=yj*fac
          ggg(3)=zj*fac
          if (j.lt.i) then
cd          write (iout,*) 'j<i'
C Uncomment following three lines for SC-p interactions
c           do k=1,3
c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
c           enddo
          else
cd          write (iout,*) 'j>i'
            do k=1,3
              ggg(k)=-ggg(k)
C Uncomment following line for SC-p interactions
c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
            enddo
          endif
          do k=1,3
            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
          enddo
          kstart=min0(i+1,j)
          kend=max0(i-1,j-1)
cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
cd        write (iout,*) ggg(1),ggg(2),ggg(3)
          do k=kstart,kend
            do l=1,3
              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
            enddo
          enddo
          endif
        enddo
        enddo ! iint
 1225   continue
      enddo ! i
      do i=1,nct
        do j=1,3
          gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
          gradx_scp(j,i)=expon*gradx_scp(j,i)
        enddo
      enddo
C******************************************************************************
C
C                              N O T E !!!
C
C To save time the factor EXPON has been extracted from ALL components
C of GVDWC and GRADX. Remember to multiply them by this factor before further 
C use!
C
C******************************************************************************
      return
      end
C--------------------------------------------------------------------------
      subroutine edis(ehpb)
C 
C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
C
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.SBRIDGE'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.VAR'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTROL'
      dimension ggg(3)
      ehpb=0.0D0
cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
cd    print *,'link_start=',link_start,' link_end=',link_end
      if (link_end.eq.0) return
      do i=link_start,link_end
C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
C CA-CA distance used in regularization of structure.
        ii=ihpb(i)
        jj=jhpb(i)
C iii and jjj point to the residues for which the distance is assigned.
        if (ii.gt.nres) then
          iii=ii-nres
          jjj=jj-nres 
        else
          iii=ii
          jjj=jj
        endif
C 24/11/03 AL: SS bridges handled separately because of introducing a specific
C    distance and angle dependent SS bond potential.
C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
C     &  iabs(itype(jjj)).eq.1) then
C          call ssbond_ene(iii,jjj,eij)
C          ehpb=ehpb+2*eij
C        else
       if (.not.dyn_ss .and. i.le.nss) then
         if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
     & iabs(itype(jjj)).eq.1) then
          call ssbond_ene(iii,jjj,eij)
          ehpb=ehpb+2*eij
           endif !ii.gt.neres
        else if (ii.gt.nres .and. jj.gt.nres) then
c Restraints from contact prediction
          dd=dist(ii,jj)
          if (constr_dist.eq.11) then
C            ehpb=ehpb+fordepth(i)**4.0d0
C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
            ehpb=ehpb+fordepth(i)**4.0d0
     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
            fac=fordepth(i)**4.0d0
     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
C     &    ehpb,fordepth(i),dd
C             print *,"TUTU"
C            write(iout,*) ehpb,"atu?"
C            ehpb,"tu?"
C            fac=fordepth(i)**4.0d0
C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
           else !constr_dist.eq.11
          if (dhpb1(i).gt.0.0d0) then
            ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
            fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
c            write (iout,*) "beta nmr",
c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
          else !dhpb(i).gt.0.00

C Calculate the distance between the two points and its difference from the
C target distance.
        dd=dist(ii,jj)
        rdis=dd-dhpb(i)
C Get the force constant corresponding to this distance.
        waga=forcon(i)
C Calculate the contribution to energy.
        ehpb=ehpb+waga*rdis*rdis
C
C Evaluate gradient.
C
        fac=waga*rdis/dd
        endif !dhpb(i).gt.0
        endif
cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
cd   &   ' waga=',waga,' fac=',fac
        do j=1,3
          ggg(j)=fac*(c(j,jj)-c(j,ii))
        enddo
cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
C If this is a SC-SC distance, we need to calculate the contributions to the
C Cartesian gradient in the SC vectors (ghpbx).
        if (iii.lt.ii) then
          do j=1,3
            ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
            ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
          enddo
        endif
        else !ii.gt.nres
C          write(iout,*) "before"
          dd=dist(ii,jj)
C          write(iout,*) "after",dd
          if (constr_dist.eq.11) then
            ehpb=ehpb+fordepth(i)**4.0d0
     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
            fac=fordepth(i)**4.0d0
     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
C            print *,ehpb,"tu?"
C            write(iout,*) ehpb,"btu?",
C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
C     &    ehpb,fordepth(i),dd
           else
          if (dhpb1(i).gt.0.0d0) then
            ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
            fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
c            write (iout,*) "alph nmr",
c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
          else
            rdis=dd-dhpb(i)
C Get the force constant corresponding to this distance.
            waga=forcon(i)
C Calculate the contribution to energy.
            ehpb=ehpb+waga*rdis*rdis
c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
C
C Evaluate gradient.
C
            fac=waga*rdis/dd
          endif
          endif
        do j=1,3
          ggg(j)=fac*(c(j,jj)-c(j,ii))
        enddo
cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
C If this is a SC-SC distance, we need to calculate the contributions to the
C Cartesian gradient in the SC vectors (ghpbx).
        if (iii.lt.ii) then
          do j=1,3
            ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
            ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
          enddo
        endif
        do j=iii,jjj-1
          do k=1,3
            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
          enddo
        enddo
        endif
      enddo
      if (constr_dist.ne.11) ehpb=0.5D0*ehpb
      return
      end
C--------------------------------------------------------------------------
      subroutine ssbond_ene(i,j,eij)
C 
C Calculate the distance and angle dependent SS-bond potential energy
C using a free-energy function derived based on RHF/6-31G** ab initio
C calculations of diethyl disulfide.
C
C A. Liwo and U. Kozlowska, 11/24/03
C
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.SBRIDGE'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.LOCAL'
      include 'COMMON.INTERACT'
      include 'COMMON.VAR'
      include 'COMMON.IOUNITS'
      double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
      itypi=iabs(itype(i))
      xi=c(1,nres+i)
      yi=c(2,nres+i)
      zi=c(3,nres+i)
      dxi=dc_norm(1,nres+i)
      dyi=dc_norm(2,nres+i)
      dzi=dc_norm(3,nres+i)
      dsci_inv=dsc_inv(itypi)
      itypj=iabs(itype(j))
      dscj_inv=dsc_inv(itypj)
      xj=c(1,nres+j)-xi
      yj=c(2,nres+j)-yi
      zj=c(3,nres+j)-zi
      dxj=dc_norm(1,nres+j)
      dyj=dc_norm(2,nres+j)
      dzj=dc_norm(3,nres+j)
      rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
      rij=dsqrt(rrij)
      erij(1)=xj*rij
      erij(2)=yj*rij
      erij(3)=zj*rij
      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
      om12=dxi*dxj+dyi*dyj+dzi*dzj
      do k=1,3
        dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
        dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
      enddo
      rij=1.0d0/rij
      deltad=rij-d0cm
      deltat1=1.0d0-om1
      deltat2=1.0d0+om2
      deltat12=om2-om1+2.0d0
      cosphi=om12-om1*om2
      eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
     &  +akct*deltad*deltat12
     &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
c     &  " deltat12",deltat12," eij",eij 
      ed=2*akcm*deltad+akct*deltat12
      pom1=akct*deltad
      pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
      eom1=-2*akth*deltat1-pom1-om2*pom2
      eom2= 2*akth*deltat2+pom1-om1*pom2
      eom12=pom2
      do k=1,3
        gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
      enddo
      do k=1,3
        ghpbx(k,i)=ghpbx(k,i)-gg(k)
     &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
        ghpbx(k,j)=ghpbx(k,j)+gg(k)
     &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
      enddo
C
C Calculate the components of the gradient in DC and X
C
      do k=i,j-1
        do l=1,3
          ghpbc(l,k)=ghpbc(l,k)+gg(l)
        enddo
      enddo
      return
      end
C--------------------------------------------------------------------------


c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
      subroutine e_modeller(ehomology_constr)
      implicit real*8 (a-h,o-z)

      include 'DIMENSIONS'

      integer nnn, i, j, k, ki, irec, l
      integer katy, odleglosci, test7
      real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
      real*8 distance(max_template),distancek(max_template),
     &    min_odl,godl(max_template),dih_diff(max_template)

c
c     FP - 30/10/2014 Temporary specifications for homology restraints
c
      double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
     &                 sgtheta
      double precision, dimension (maxres) :: guscdiff,usc_diff
      double precision, dimension (max_template) ::
     &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
     &           theta_diff

      include 'COMMON.SBRIDGE'
      include 'COMMON.CHAIN'
      include 'COMMON.GEO'
      include 'COMMON.DERIV'
      include 'COMMON.LOCAL'
      include 'COMMON.INTERACT'
      include 'COMMON.VAR'
      include 'COMMON.IOUNITS'
      include 'COMMON.CONTROL'
      include 'COMMON.HOMRESTR'
c
      include 'COMMON.SETUP'
      include 'COMMON.NAMES'

      do i=1,max_template
        distancek(i)=9999999.9
      enddo

      odleg=0.0d0

c Pseudo-energy and gradient from homology restraints (MODELLER-like
c function)
C AL 5/2/14 - Introduce list of restraints
c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
#ifdef DEBUG
      write(iout,*) "------- dist restrs start -------"
      write (iout,*) "link_start_homo",link_start_homo,
     &    " link_end_homo",link_end_homo
#endif
      do ii = link_start_homo,link_end_homo
         i = ires_homo(ii)
         j = jres_homo(ii)
         dij=dist(i,j)
c        write (iout,*) "dij(",i,j,") =",dij
         do k=1,constr_homology
           if(.not.l_homo(k,ii)) cycle
           distance(k)=odl(k,ii)-dij
c          write (iout,*) "distance(",k,") =",distance(k)
c
c          For Gaussian-type Urestr
c
           distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
c          write (iout,*) "distancek(",k,") =",distancek(k)
c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
c
c          For Lorentzian-type Urestr
c
           if (waga_dist.lt.0.0d0) then
              sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
              distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
     &                     (distance(k)**2+sigma_odlir(k,ii)**2))
           endif
         enddo
         
c         min_odl=minval(distancek)
         do kk=1,constr_homology
          if(l_homo(kk,ii)) then 
            min_odl=distancek(kk)
            exit
          endif
         enddo
         do kk=1,constr_homology
          if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl) 
     &              min_odl=distancek(kk)
         enddo
c        write (iout,* )"min_odl",min_odl
#ifdef DEBUG
         write (iout,*) "ij dij",i,j,dij
         write (iout,*) "distance",(distance(k),k=1,constr_homology)
         write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
         write (iout,* )"min_odl",min_odl
#endif
         odleg2=0.0d0
         do k=1,constr_homology
c Nie wiem po co to liczycie jeszcze raz!
c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/ 
c     &              (2*(sigma_odl(i,j,k))**2))
           if(.not.l_homo(k,ii)) cycle
           if (waga_dist.ge.0.0d0) then
c
c          For Gaussian-type Urestr
c
            godl(k)=dexp(-distancek(k)+min_odl)
            odleg2=odleg2+godl(k)
c
c          For Lorentzian-type Urestr
c
           else
            odleg2=odleg2+distancek(k)
           endif

ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)

         enddo
c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
#ifdef DEBUG
         write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
         write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
#endif
           if (waga_dist.ge.0.0d0) then
c
c          For Gaussian-type Urestr
c
              odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
c
c          For Lorentzian-type Urestr
c
           else
              odleg=odleg+odleg2/constr_homology
           endif
c
#ifdef GRAD
c        write (iout,*) "odleg",odleg ! sum of -ln-s
c Gradient
c
c          For Gaussian-type Urestr
c
         if (waga_dist.ge.0.0d0) sum_godl=odleg2
         sum_sgodl=0.0d0
         do k=1,constr_homology
c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
c     &           *waga_dist)+min_odl
c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
c
         if(.not.l_homo(k,ii)) cycle
         if (waga_dist.ge.0.0d0) then
c          For Gaussian-type Urestr
c
           sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
c
c          For Lorentzian-type Urestr
c
         else
           sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
     &           sigma_odlir(k,ii)**2)**2)
         endif
           sum_sgodl=sum_sgodl+sgodl

c            sgodl2=sgodl2+sgodl
c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
c      write(iout,*) "constr_homology=",constr_homology
c      write(iout,*) i, j, k, "TEST K"
         enddo
         if (waga_dist.ge.0.0d0) then
c
c          For Gaussian-type Urestr
c
            grad_odl3=waga_homology(iset)*waga_dist
     &                *sum_sgodl/(sum_godl*dij)
c
c          For Lorentzian-type Urestr
c
         else
c Original grad expr modified by analogy w Gaussian-type Urestr grad
c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
            grad_odl3=-waga_homology(iset)*waga_dist*
     &                sum_sgodl/(constr_homology*dij)
         endif
c
c        grad_odl3=sum_sgodl/(sum_godl*dij)


c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))

ccc      write(iout,*) godl, sgodl, grad_odl3

c          grad_odl=grad_odl+grad_odl3

         do jik=1,3
            ggodl=grad_odl3*(c(jik,i)-c(jik,j))
ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl, 
ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
            ghpbc(jik,i)=ghpbc(jik,i)+ggodl
            ghpbc(jik,j)=ghpbc(jik,j)-ggodl
ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
c         if (i.eq.25.and.j.eq.27) then
c         write(iout,*) "jik",jik,"i",i,"j",j
c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
c         write(iout,*) "grad_odl3",grad_odl3
c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
c         write(iout,*) "ggodl",ggodl
c         write(iout,*) "ghpbc(",jik,i,")",
c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
c     &                 ghpbc(jik,j)   
c         endif
         enddo
#endif
ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=", 
ccc     & dLOG(odleg2),"-odleg=", -odleg

      enddo ! ii-loop for dist
#ifdef DEBUG
      write(iout,*) "------- dist restrs end -------"
c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or. 
c    &     waga_d.eq.1.0d0) call sum_gradient
#endif
c Pseudo-energy and gradient from dihedral-angle restraints from
c homology templates
c      write (iout,*) "End of distance loop"
c      call flush(iout)
      kat=0.0d0
c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
#ifdef DEBUG
      write(iout,*) "------- dih restrs start -------"
      do i=idihconstr_start_homo,idihconstr_end_homo
        write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
      enddo
#endif
      do i=idihconstr_start_homo,idihconstr_end_homo
        kat2=0.0d0
c        betai=beta(i,i+1,i+2,i+3)
        betai = phi(i)
c       write (iout,*) "betai =",betai
        do k=1,constr_homology
          dih_diff(k)=pinorm(dih(k,i)-betai)
c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
c     &                                   -(6.28318-dih_diff(i,k))
c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
c     &                                   6.28318+dih_diff(i,k)

          kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
          gdih(k)=dexp(kat3)
          kat2=kat2+gdih(k)
c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
c          write(*,*)""
        enddo
c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
#ifdef DEBUG
        write (iout,*) "i",i," betai",betai," kat2",kat2
        write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
#endif
        if (kat2.le.1.0d-14) cycle
        kat=kat-dLOG(kat2/constr_homology)
c       write (iout,*) "kat",kat ! sum of -ln-s

ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
ccc     & dLOG(kat2), "-kat=", -kat

#ifdef GRAD
c ----------------------------------------------------------------------
c Gradient
c ----------------------------------------------------------------------

        sum_gdih=kat2
        sum_sgdih=0.0d0
        do k=1,constr_homology
          sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
          sum_sgdih=sum_sgdih+sgdih
        enddo
c       grad_dih3=sum_sgdih/sum_gdih
        grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih

c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
ccc     & gloc(nphi+i-3,icg)
        gloc(i,icg)=gloc(i,icg)+grad_dih3
c        if (i.eq.25) then
c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
c        endif
ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
ccc     & gloc(nphi+i-3,icg)
#endif
      enddo ! i-loop for dih
#ifdef DEBUG
      write(iout,*) "------- dih restrs end -------"
#endif

c Pseudo-energy and gradient for theta angle restraints from
c homology templates
c FP 01/15 - inserted from econstr_local_test.F, loop structure
c adapted

c
c     For constr_homology reference structures (FP)
c     
c     Uconst_back_tot=0.0d0
      Eval=0.0d0
      Erot=0.0d0
c     Econstr_back legacy
#ifdef GRAD
      do i=1,nres
c     do i=ithet_start,ithet_end
       dutheta(i)=0.0d0
c     enddo
c     do i=loc_start,loc_end
        do j=1,3
          duscdiff(j,i)=0.0d0
          duscdiffx(j,i)=0.0d0
        enddo
      enddo
#endif
c
c     do iref=1,nref
c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
c     write (iout,*) "waga_theta",waga_theta
      if (waga_theta.gt.0.0d0) then
#ifdef DEBUG
      write (iout,*) "usampl",usampl
      write(iout,*) "------- theta restrs start -------"
c     do i=ithet_start,ithet_end
c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
c     enddo
#endif
c     write (iout,*) "maxres",maxres,"nres",nres

      do i=ithet_start,ithet_end
c
c     do i=1,nfrag_back
c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
c
c Deviation of theta angles wrt constr_homology ref structures
c
        utheta_i=0.0d0 ! argument of Gaussian for single k
        gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
c       over residues in a fragment
c       write (iout,*) "theta(",i,")=",theta(i)
        do k=1,constr_homology
c
c         dtheta_i=theta(j)-thetaref(j,iref)
c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
          theta_diff(k)=thetatpl(k,i)-theta(i)
c
          utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
          gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
          gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
c         Gradient for single Gaussian restraint in subr Econstr_back
c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
c
        enddo
c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps

c
#ifdef GRAD
c         Gradient for multiple Gaussian restraint
        sum_gtheta=gutheta_i
        sum_sgtheta=0.0d0
        do k=1,constr_homology
c        New generalized expr for multiple Gaussian from Econstr_back
         sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
c
c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
          sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
        enddo
c
c       Final value of gradient using same var as in Econstr_back
        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
     &               *waga_homology(iset)
c       dutheta(i)=sum_sgtheta/sum_gtheta
c
c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
#endif
        Eval=Eval-dLOG(gutheta_i/constr_homology)
c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
c       Uconst_back=Uconst_back+utheta(i)
      enddo ! (i-loop for theta)
#ifdef DEBUG
      write(iout,*) "------- theta restrs end -------"
#endif
      endif
c
c Deviation of local SC geometry
c
c Separation of two i-loops (instructed by AL - 11/3/2014)
c
c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
c     write (iout,*) "waga_d",waga_d

#ifdef DEBUG
      write(iout,*) "------- SC restrs start -------"
      write (iout,*) "Initial duscdiff,duscdiffx"
      do i=loc_start,loc_end
        write (iout,*) i,(duscdiff(jik,i),jik=1,3),
     &                 (duscdiffx(jik,i),jik=1,3)
      enddo
#endif
      do i=loc_start,loc_end
        usc_diff_i=0.0d0 ! argument of Gaussian for single k
        guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
c       write(iout,*) "xxtab, yytab, zztab"
c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
        do k=1,constr_homology
c
          dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
c                                    Original sign inverted for calc of gradients (s. Econstr_back)
          dyy=-yytpl(k,i)+yytab(i) ! ibid y
          dzz=-zztpl(k,i)+zztab(i) ! ibid z
c         write(iout,*) "dxx, dyy, dzz"
c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
c
          usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
c         uscdiffk(k)=usc_diff(i)
          guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
          guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
c     &      xxref(j),yyref(j),zzref(j)
        enddo
c
c       Gradient 
c
c       Generalized expression for multiple Gaussian acc to that for a single 
c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
c
c       Original implementation
c       sum_guscdiff=guscdiff(i)
c
c       sum_sguscdiff=0.0d0
c       do k=1,constr_homology
c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d? 
c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
c          sum_sguscdiff=sum_sguscdiff+sguscdiff
c       enddo
c
c       Implementation of new expressions for gradient (Jan. 2015)
c
c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
#ifdef GRAD
        do k=1,constr_homology 
c
c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
c       before. Now the drivatives should be correct
c
          dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
c                                  Original sign inverted for calc of gradients (s. Econstr_back)
          dyy=-yytpl(k,i)+yytab(i) ! ibid y
          dzz=-zztpl(k,i)+zztab(i) ! ibid z
c
c         New implementation
c
          sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
     &                 sigma_d(k,i) ! for the grad wrt r' 
c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
c
c
c        New implementation
         sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
         do jik=1,3
            duscdiff(jik,i-1)=duscdiff(jik,i-1)+
     &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
     &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
            duscdiff(jik,i)=duscdiff(jik,i)+
     &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
     &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
            duscdiffx(jik,i)=duscdiffx(jik,i)+
     &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
     &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
c
#ifdef DEBUG
             write(iout,*) "jik",jik,"i",i
             write(iout,*) "dxx, dyy, dzz"
             write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
             write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
c            endif
#endif
         enddo
        enddo
#endif
c
c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
c
c        write (iout,*) i," uscdiff",uscdiff(i)
c
c Put together deviations from local geometry

c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
c      &            wfrag_back(3,i,iset)*uscdiff(i)
        Erot=Erot-dLOG(guscdiff(i)/constr_homology)
c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
c       Uconst_back=Uconst_back+usc_diff(i)
c
c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
c
c     New implment: multiplied by sum_sguscdiff
c

      enddo ! (i-loop for dscdiff)

c      endif

#ifdef DEBUG
      write(iout,*) "------- SC restrs end -------"
        write (iout,*) "------ After SC loop in e_modeller ------"
        do i=loc_start,loc_end
         write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
         write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
        enddo
      if (waga_theta.eq.1.0d0) then
      write (iout,*) "in e_modeller after SC restr end: dutheta"
      do i=ithet_start,ithet_end
        write (iout,*) i,dutheta(i)
      enddo
      endif
      if (waga_d.eq.1.0d0) then
      write (iout,*) "e_modeller after SC loop: duscdiff/x"
      do i=1,nres
        write (iout,*) i,(duscdiff(j,i),j=1,3)
        write (iout,*) i,(duscdiffx(j,i),j=1,3)
      enddo
      endif
#endif

c Total energy from homology restraints
#ifdef DEBUG
      write (iout,*) "odleg",odleg," kat",kat
      write (iout,*) "odleg",odleg," kat",kat
      write (iout,*) "Eval",Eval," Erot",Erot
      write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
      write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
      write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
      write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
#endif
c
c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
c
c     ehomology_constr=odleg+kat
c
c     For Lorentzian-type Urestr
c

      if (waga_dist.ge.0.0d0) then
c
c          For Gaussian-type Urestr
c
        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
c     write (iout,*) "ehomology_constr=",ehomology_constr
      else
c
c          For Lorentzian-type Urestr
c  
        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
c     write (iout,*) "ehomology_constr=",ehomology_constr
      endif
#ifdef DEBUG
      write (iout,*) "iset",iset," waga_homology",waga_homology(iset)
      write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
     & " Eval",waga_theta,Eval," Erot",waga_d,Erot
      write (iout,*) "ehomology_constr",ehomology_constr
#endif
      return

  748 format(a8,f12.3,a6,f12.3,a7,f12.3)
  747 format(a12,i4,i4,i4,f8.3,f8.3)
  746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
  778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
  779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
     &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
      end
C--------------------------------------------------------------------------

C--------------------------------------------------------------------------
      subroutine ebond(estr)
c
c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
c
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.LOCAL'
      include 'COMMON.GEO'
      include 'COMMON.INTERACT'
      include 'COMMON.DERIV'
      include 'COMMON.VAR'
      include 'COMMON.CHAIN'
      include 'COMMON.IOUNITS'
      include 'COMMON.NAMES'
      include 'COMMON.FFIELD'
      include 'COMMON.CONTROL'
      logical energy_dec /.false./
      double precision u(3),ud(3)
      estr=0.0d0
      estr1=0.0d0
      do i=nnt+1,nct
        if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
C          do j=1,3
C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
C     &      *dc(j,i-1)/vbld(i)
C          enddo
C          if (energy_dec) write(iout,*)
C     &       "estr1",i,vbld(i),distchainmax,
C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
C        else
         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
        diff = vbld(i)-vbldpDUM
         else
          diff = vbld(i)-vbldp0
c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
         endif
          estr=estr+diff*diff
          do j=1,3
            gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
          enddo
C        endif
C        write (iout,'(a7,i5,4f7.3)')
C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
      enddo
      estr=0.5d0*AKP*estr+estr1
c
c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
c
      do i=nnt,nct
        iti=iabs(itype(i))
        if (iti.ne.10 .and. iti.ne.ntyp1) then
          nbi=nbondterm(iti)
          if (nbi.eq.1) then
            diff=vbld(i+nres)-vbldsc0(1,iti)
c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
            estr=estr+0.5d0*AKSC(1,iti)*diff*diff
            do j=1,3
              gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
            enddo
          else
            do j=1,nbi
              diff=vbld(i+nres)-vbldsc0(j,iti)
              ud(j)=aksc(j,iti)*diff
              u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
            enddo
            uprod=u(1)
            do j=2,nbi
              uprod=uprod*u(j)
            enddo
            usum=0.0d0
            usumsqder=0.0d0
            do j=1,nbi
              uprod1=1.0d0
              uprod2=1.0d0
              do k=1,nbi
                if (k.ne.j) then
                  uprod1=uprod1*u(k)
                  uprod2=uprod2*u(k)*u(k)
                endif
              enddo
              usum=usum+uprod1
              usumsqder=usumsqder+ud(j)*uprod2
            enddo
c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
            estr=estr+uprod/usum
            do j=1,3
             gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
            enddo
          endif
        endif
      enddo
      return
      end
#ifdef CRYST_THETA
C--------------------------------------------------------------------------
      subroutine ebend(etheta,ethetacnstr)
C
C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
C angles gamma and its derivatives in consecutive thetas and gammas.
C
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.LOCAL'
      include 'COMMON.GEO'
      include 'COMMON.INTERACT'
      include 'COMMON.DERIV'
      include 'COMMON.VAR'
      include 'COMMON.CHAIN'
      include 'COMMON.IOUNITS'
      include 'COMMON.NAMES'
      include 'COMMON.FFIELD'
      include 'COMMON.TORCNSTR'
      common /calcthet/ term1,term2,termm,diffak,ratak,
     & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
     & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
      double precision y(2),z(2)
      delta=0.02d0*pi
c      time11=dexp(-2*time)
c      time12=1.0d0
      etheta=0.0D0
c      write (iout,*) "nres",nres
c     write (*,'(a,i2)') 'EBEND ICG=',icg
c      write (iout,*) ithet_start,ithet_end
      do i=ithet_start,ithet_end
C        if (itype(i-1).eq.ntyp1) cycle
c        if (i.le.2) cycle
        if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
     &  .or.itype(i).eq.ntyp1) cycle
C Zero the energy function and its derivative at 0 or pi.
        call splinthet(theta(i),0.5d0*delta,ss,ssd)
        it=itype(i-1)
        ichir1=isign(1,itype(i-2))
        ichir2=isign(1,itype(i))
         if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
         if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
         if (itype(i-1).eq.10) then
          itype1=isign(10,itype(i-2))
          ichir11=isign(1,itype(i-2))
          ichir12=isign(1,itype(i-2))
          itype2=isign(10,itype(i))
          ichir21=isign(1,itype(i))
          ichir22=isign(1,itype(i))
         endif
         if (i.eq.3) then
          y(1)=0.0D0
          y(2)=0.0D0
          else

        if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
#ifdef OSF
          phii=phi(i)
c          icrc=0
c          call proc_proc(phii,icrc)
          if (icrc.eq.1) phii=150.0
#else
          phii=phi(i)
#endif
          y(1)=dcos(phii)
          y(2)=dsin(phii)
        else
          y(1)=0.0D0
          y(2)=0.0D0
        endif
        endif
        if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
#ifdef OSF
          phii1=phi(i+1)
c          icrc=0
c          call proc_proc(phii1,icrc)
          if (icrc.eq.1) phii1=150.0
          phii1=pinorm(phii1)
          z(1)=cos(phii1)
#else
          phii1=phi(i+1)
          z(1)=dcos(phii1)
#endif
          z(2)=dsin(phii1)
        else
          z(1)=0.0D0
          z(2)=0.0D0
        endif
C Calculate the "mean" value of theta from the part of the distribution
C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
C In following comments this theta will be referred to as t_c.
        thet_pred_mean=0.0d0
        do k=1,2
            athetk=athet(k,it,ichir1,ichir2)
            bthetk=bthet(k,it,ichir1,ichir2)
          if (it.eq.10) then
             athetk=athet(k,itype1,ichir11,ichir12)
             bthetk=bthet(k,itype2,ichir21,ichir22)
          endif
          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
        enddo
c        write (iout,*) "thet_pred_mean",thet_pred_mean
        dthett=thet_pred_mean*ssd
        thet_pred_mean=thet_pred_mean*ss+a0thet(it)
c        write (iout,*) "thet_pred_mean",thet_pred_mean
C Derivatives of the "mean" values in gamma1 and gamma2.
        dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
     &+athet(2,it,ichir1,ichir2)*y(1))*ss
         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
     &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
         if (it.eq.10) then
      dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
     &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
        dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
     &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
         endif
        if (theta(i).gt.pi-delta) then
          call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
     &         E_tc0)
          call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
          call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
          call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
     &        E_theta)
          call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
     &        E_tc)
        else if (theta(i).lt.delta) then
          call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
          call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
          call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
     &        E_theta)
          call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
          call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
     &        E_tc)
        else
          call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
     &        E_theta,E_tc)
        endif
        etheta=etheta+ethetai
c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
c     &    rad2deg*phii,rad2deg*phii1,ethetai
        if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
        if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
        gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
c 1215   continue
      enddo
C Ufff.... We've done all this!!! 
C now constrains
      ethetacnstr=0.0d0
C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
      do i=1,ntheta_constr
        itheta=itheta_constr(i)
        thetiii=theta(itheta)
        difi=pinorm(thetiii-theta_constr0(i))
        if (difi.gt.theta_drange(i)) then
          difi=difi-theta_drange(i)
          ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
          gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
     &    +for_thet_constr(i)*difi**3
        else if (difi.lt.-drange(i)) then
          difi=difi+drange(i)
          ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
          gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
     &    +for_thet_constr(i)*difi**3
        else
          difi=0.0
        endif
C       if (energy_dec) then
C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
C     &    i,itheta,rad2deg*thetiii,
C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
C     &    gloc(itheta+nphi-2,icg)
C        endif
      enddo
      return
      end
C---------------------------------------------------------------------------
      subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
     &     E_tc)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'COMMON.LOCAL'
      include 'COMMON.IOUNITS'
      common /calcthet/ term1,term2,termm,diffak,ratak,
     & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
     & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
C Calculate the contributions to both Gaussian lobes.
C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
C The "polynomial part" of the "standard deviation" of this part of 
C the distribution.
        sig=polthet(3,it)
        do j=2,0,-1
          sig=sig*thet_pred_mean+polthet(j,it)
        enddo
C Derivative of the "interior part" of the "standard deviation of the" 
C gamma-dependent Gaussian lobe in t_c.
        sigtc=3*polthet(3,it)
        do j=2,1,-1
          sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
        enddo
        sigtc=sig*sigtc
C Set the parameters of both Gaussian lobes of the distribution.
C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
        fac=sig*sig+sigc0(it)
        sigcsq=fac+fac
        sigc=1.0D0/sigcsq
C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
        sigsqtc=-4.0D0*sigcsq*sigtc
c       print *,i,sig,sigtc,sigsqtc
C Following variable (sigtc) is d[sigma(t_c)]/dt_c
        sigtc=-sigtc/(fac*fac)
C Following variable is sigma(t_c)**(-2)
        sigcsq=sigcsq*sigcsq
        sig0i=sig0(it)
        sig0inv=1.0D0/sig0i**2
        delthec=thetai-thet_pred_mean
        delthe0=thetai-theta0i
        term1=-0.5D0*sigcsq*delthec*delthec
        term2=-0.5D0*sig0inv*delthe0*delthe0
C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
C NaNs in taking the logarithm. We extract the largest exponent which is added
C to the energy (this being the log of the distribution) at the end of energy
C term evaluation for this virtual-bond angle.
        if (term1.gt.term2) then
          termm=term1
          term2=dexp(term2-termm)
          term1=1.0d0
        else
          termm=term2
          term1=dexp(term1-termm)
          term2=1.0d0
        endif
C The ratio between the gamma-independent and gamma-dependent lobes of
C the distribution is a Gaussian function of thet_pred_mean too.
        diffak=gthet(2,it)-thet_pred_mean
        ratak=diffak/gthet(3,it)**2
        ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
C Let's differentiate it in thet_pred_mean NOW.
        aktc=ak*ratak
C Now put together the distribution terms to make complete distribution.
        termexp=term1+ak*term2
        termpre=sigc+ak*sig0i
C Contribution of the bending energy from this theta is just the -log of
C the sum of the contributions from the two lobes and the pre-exponential
C factor. Simple enough, isn't it?
        ethetai=(-dlog(termexp)-termm+dlog(termpre))
C NOW the derivatives!!!
C 6/6/97 Take into account the deformation.
        E_theta=(delthec*sigcsq*term1
     &       +ak*delthe0*sig0inv*term2)/termexp
        E_tc=((sigtc+aktc*sig0i)/termpre
     &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
     &       aktc*term2)/termexp)
      return
      end
c-----------------------------------------------------------------------------
      subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'COMMON.LOCAL'
      include 'COMMON.IOUNITS'
      common /calcthet/ term1,term2,termm,diffak,ratak,
     & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
     & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
      delthec=thetai-thet_pred_mean
      delthe0=thetai-theta0i
C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
      t3 = thetai-thet_pred_mean
      t6 = t3**2
      t9 = term1
      t12 = t3*sigcsq
      t14 = t12+t6*sigsqtc
      t16 = 1.0d0
      t21 = thetai-theta0i
      t23 = t21**2
      t26 = term2
      t27 = t21*t26
      t32 = termexp
      t40 = t32**2
      E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
     & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
     & *(-t12*t9-ak*sig0inv*t27)
      return
      end
#else
C--------------------------------------------------------------------------
      subroutine ebend(etheta,ethetacnstr)
C
C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
C angles gamma and its derivatives in consecutive thetas and gammas.
C ab initio-derived potentials from 
c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
C
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.LOCAL'
      include 'COMMON.GEO'
      include 'COMMON.INTERACT'
      include 'COMMON.DERIV'
      include 'COMMON.VAR'
      include 'COMMON.CHAIN'
      include 'COMMON.IOUNITS'
      include 'COMMON.NAMES'
      include 'COMMON.FFIELD'
      include 'COMMON.CONTROL'
      include 'COMMON.TORCNSTR'
      double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
     & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
     & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
     & sinph1ph2(maxdouble,maxdouble)
      logical lprn /.false./, lprn1 /.false./
      etheta=0.0D0
c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
      do i=ithet_start,ithet_end
c        if (i.eq.2) cycle
c        print *,i,itype(i-1),itype(i),itype(i-2)
        if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
     &  .or.(itype(i).eq.ntyp1)) cycle
C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF

        if (iabs(itype(i+1)).eq.20) iblock=2
        if (iabs(itype(i+1)).ne.20) iblock=1
        dethetai=0.0d0
        dephii=0.0d0
        dephii1=0.0d0
        theti2=0.5d0*theta(i)
        ityp2=ithetyp((itype(i-1)))
        do k=1,nntheterm
          coskt(k)=dcos(k*theti2)
          sinkt(k)=dsin(k*theti2)
        enddo
        if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
#ifdef OSF
          phii=phi(i)
          if (phii.ne.phii) phii=150.0
#else
          phii=phi(i)
#endif
          ityp1=ithetyp((itype(i-2)))
          do k=1,nsingle
            cosph1(k)=dcos(k*phii)
            sinph1(k)=dsin(k*phii)
          enddo
        else
          phii=0.0d0
          ityp1=ithetyp(itype(i-2))
          do k=1,nsingle
            cosph1(k)=0.0d0
            sinph1(k)=0.0d0
          enddo 
        endif
        if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
#ifdef OSF
          phii1=phi(i+1)
          if (phii1.ne.phii1) phii1=150.0
          phii1=pinorm(phii1)
#else
          phii1=phi(i+1)
#endif
          ityp3=ithetyp((itype(i)))
          do k=1,nsingle
            cosph2(k)=dcos(k*phii1)
            sinph2(k)=dsin(k*phii1)
          enddo
        else
          phii1=0.0d0
          ityp3=ithetyp(itype(i))
          do k=1,nsingle
            cosph2(k)=0.0d0
            sinph2(k)=0.0d0
          enddo
        endif  
c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
c        call flush(iout)
        ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
        do k=1,ndouble
          do l=1,k-1
            ccl=cosph1(l)*cosph2(k-l)
            ssl=sinph1(l)*sinph2(k-l)
            scl=sinph1(l)*cosph2(k-l)
            csl=cosph1(l)*sinph2(k-l)
            cosph1ph2(l,k)=ccl-ssl
            cosph1ph2(k,l)=ccl+ssl
            sinph1ph2(l,k)=scl+csl
            sinph1ph2(k,l)=scl-csl
          enddo
        enddo
        if (lprn) then
        write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
     &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
        write (iout,*) "coskt and sinkt"
        do k=1,nntheterm
          write (iout,*) k,coskt(k),sinkt(k)
        enddo
        endif
        do k=1,ntheterm
          ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
          dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
     &      *coskt(k)
          if (lprn)
     &    write (iout,*) "k",k," aathet",
     &    aathet(k,ityp1,ityp2,ityp3,iblock),
     &     " ethetai",ethetai
        enddo
        if (lprn) then
        write (iout,*) "cosph and sinph"
        do k=1,nsingle
          write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
        enddo
        write (iout,*) "cosph1ph2 and sinph2ph2"
        do k=2,ndouble
          do l=1,k-1
            write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
     &         sinph1ph2(l,k),sinph1ph2(k,l) 
          enddo
        enddo
        write(iout,*) "ethetai",ethetai
        endif
        do m=1,ntheterm2
          do k=1,nsingle
            aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
     &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
     &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
     &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
            ethetai=ethetai+sinkt(m)*aux
            dethetai=dethetai+0.5d0*m*aux*coskt(m)
            dephii=dephii+k*sinkt(m)*(
     &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
     &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
            dephii1=dephii1+k*sinkt(m)*(
     &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
     &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
            if (lprn)
     &      write (iout,*) "m",m," k",k," bbthet",
     &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
     &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
     &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
     &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
          enddo
        enddo
        if (lprn)
     &  write(iout,*) "ethetai",ethetai
        do m=1,ntheterm3
          do k=2,ndouble
            do l=1,k-1
              aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
     &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
     &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
     &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
              ethetai=ethetai+sinkt(m)*aux
              dethetai=dethetai+0.5d0*m*coskt(m)*aux
              dephii=dephii+l*sinkt(m)*(
     &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
     &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
     &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
     &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
              dephii1=dephii1+(k-l)*sinkt(m)*(
     &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
     &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
     &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
     &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
              if (lprn) then
              write (iout,*) "m",m," k",k," l",l," ffthet",
     &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
     &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
     &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
     &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
     &            " ethetai",ethetai
              write (iout,*) cosph1ph2(l,k)*sinkt(m),
     &            cosph1ph2(k,l)*sinkt(m),
     &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
              endif
            enddo
          enddo
        enddo
10      continue
        if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') 
     &   i,theta(i)*rad2deg,phii*rad2deg,
     &   phii1*rad2deg,ethetai
        etheta=etheta+ethetai
        if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
        if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
c        gloc(nphi+i-2,icg)=wang*dethetai
        gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
      enddo
C now constrains
      ethetacnstr=0.0d0
C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
      do i=1,ntheta_constr
        itheta=itheta_constr(i)
        thetiii=theta(itheta)
        difi=pinorm(thetiii-theta_constr0(i))
        if (difi.gt.theta_drange(i)) then
          difi=difi-theta_drange(i)
          ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
          gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
     &    +for_thet_constr(i)*difi**3
        else if (difi.lt.-drange(i)) then
          difi=difi+drange(i)
          ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
          gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
     &    +for_thet_constr(i)*difi**3
        else
          difi=0.0
        endif
C       if (energy_dec) then
C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
C     &    i,itheta,rad2deg*thetiii,
C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
C     &    gloc(itheta+nphi-2,icg)
C        endif
      enddo
      return
      end
#endif
#ifdef CRYST_SC
c-----------------------------------------------------------------------------
      subroutine esc(escloc)
C Calculate the local energy of a side chain and its derivatives in the
C corresponding virtual-bond valence angles THETA and the spherical angles 
C ALPHA and OMEGA.
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.GEO'
      include 'COMMON.LOCAL'
      include 'COMMON.VAR'
      include 'COMMON.INTERACT'
      include 'COMMON.DERIV'
      include 'COMMON.CHAIN'
      include 'COMMON.IOUNITS'
      include 'COMMON.NAMES'
      include 'COMMON.FFIELD'
      double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
     &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
      common /sccalc/ time11,time12,time112,theti,it,nlobit
      delta=0.02d0*pi
      escloc=0.0D0
c     write (iout,'(a)') 'ESC'
      do i=loc_start,loc_end
        it=itype(i)
        if (it.eq.ntyp1) cycle
        if (it.eq.10) goto 1
        nlobit=nlob(iabs(it))
c       print *,'i=',i,' it=',it,' nlobit=',nlobit
c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
        theti=theta(i+1)-pipol
        x(1)=dtan(theti)
        x(2)=alph(i)
        x(3)=omeg(i)
c        write (iout,*) "i",i," x",x(1),x(2),x(3)

        if (x(2).gt.pi-delta) then
          xtemp(1)=x(1)
          xtemp(2)=pi-delta
          xtemp(3)=x(3)
          call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
          xtemp(2)=pi
          call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
          call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
     &        escloci,dersc(2))
          call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
     &        ddersc0(1),dersc(1))
          call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
     &        ddersc0(3),dersc(3))
          xtemp(2)=pi-delta
          call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
          xtemp(2)=pi
          call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
          call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
     &            dersc0(2),esclocbi,dersc02)
          call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
     &            dersc12,dersc01)
          call splinthet(x(2),0.5d0*delta,ss,ssd)
          dersc0(1)=dersc01
          dersc0(2)=dersc02
          dersc0(3)=0.0d0
          do k=1,3
            dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
          enddo
          dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
c    &             esclocbi,ss,ssd
          escloci=ss*escloci+(1.0d0-ss)*esclocbi
c         escloci=esclocbi
c         write (iout,*) escloci
        else if (x(2).lt.delta) then
          xtemp(1)=x(1)
          xtemp(2)=delta
          xtemp(3)=x(3)
          call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
          xtemp(2)=0.0d0
          call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
          call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
     &        escloci,dersc(2))
          call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
     &        ddersc0(1),dersc(1))
          call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
     &        ddersc0(3),dersc(3))
          xtemp(2)=delta
          call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
          xtemp(2)=0.0d0
          call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
          call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
     &            dersc0(2),esclocbi,dersc02)
          call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
     &            dersc12,dersc01)
          dersc0(1)=dersc01
          dersc0(2)=dersc02
          dersc0(3)=0.0d0
          call splinthet(x(2),0.5d0*delta,ss,ssd)
          do k=1,3
            dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
          enddo
          dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
c    &             esclocbi,ss,ssd
          escloci=ss*escloci+(1.0d0-ss)*esclocbi
c         write (iout,*) escloci
        else
          call enesc(x,escloci,dersc,ddummy,.false.)
        endif

        escloc=escloc+escloci
c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc

        gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
     &   wscloc*dersc(1)
        gloc(ialph(i,1),icg)=wscloc*dersc(2)
        gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
    1   continue
      enddo
      return
      end
C---------------------------------------------------------------------------
      subroutine enesc(x,escloci,dersc,ddersc,mixed)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'COMMON.GEO'
      include 'COMMON.LOCAL'
      include 'COMMON.IOUNITS'
      common /sccalc/ time11,time12,time112,theti,it,nlobit
      double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
      double precision contr(maxlob,-1:1)
      logical mixed
c       write (iout,*) 'it=',it,' nlobit=',nlobit
        escloc_i=0.0D0
        do j=1,3
          dersc(j)=0.0D0
          if (mixed) ddersc(j)=0.0d0
        enddo
        x3=x(3)

C Because of periodicity of the dependence of the SC energy in omega we have
C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
C To avoid underflows, first compute & store the exponents.

        do iii=-1,1

          x(3)=x3+iii*dwapi
 
          do j=1,nlobit
            do k=1,3
              z(k)=x(k)-censc(k,j,it)
            enddo
            do k=1,3
              Axk=0.0D0
              do l=1,3
                Axk=Axk+gaussc(l,k,j,it)*z(l)
              enddo
              Ax(k,j,iii)=Axk
            enddo 
            expfac=0.0D0 
            do k=1,3
              expfac=expfac+Ax(k,j,iii)*z(k)
            enddo
            contr(j,iii)=expfac
          enddo ! j

        enddo ! iii

        x(3)=x3
C As in the case of ebend, we want to avoid underflows in exponentiation and
C subsequent NaNs and INFs in energy calculation.
C Find the largest exponent
        emin=contr(1,-1)
        do iii=-1,1
          do j=1,nlobit
            if (emin.gt.contr(j,iii)) emin=contr(j,iii)
          enddo 
        enddo
        emin=0.5D0*emin
cd      print *,'it=',it,' emin=',emin

C Compute the contribution to SC energy and derivatives
        do iii=-1,1

          do j=1,nlobit
            expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
cd          print *,'j=',j,' expfac=',expfac
            escloc_i=escloc_i+expfac
            do k=1,3
              dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
            enddo
            if (mixed) then
              do k=1,3,2
                ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
     &            +gaussc(k,2,j,it))*expfac
              enddo
            endif
          enddo

        enddo ! iii

        dersc(1)=dersc(1)/cos(theti)**2
        ddersc(1)=ddersc(1)/cos(theti)**2
        ddersc(3)=ddersc(3)

        escloci=-(dlog(escloc_i)-emin)
        do j=1,3
          dersc(j)=dersc(j)/escloc_i
        enddo
        if (mixed) then
          do j=1,3,2
            ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
          enddo
        endif
      return
      end
C------------------------------------------------------------------------------
      subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'COMMON.GEO'
      include 'COMMON.LOCAL'
      include 'COMMON.IOUNITS'
      common /sccalc/ time11,time12,time112,theti,it,nlobit
      double precision x(3),z(3),Ax(3,maxlob),dersc(3)
      double precision contr(maxlob)
      logical mixed

      escloc_i=0.0D0

      do j=1,3
        dersc(j)=0.0D0
      enddo

      do j=1,nlobit
        do k=1,2
          z(k)=x(k)-censc(k,j,it)
        enddo
        z(3)=dwapi
        do k=1,3
          Axk=0.0D0
          do l=1,3
            Axk=Axk+gaussc(l,k,j,it)*z(l)
          enddo
          Ax(k,j)=Axk
        enddo 
        expfac=0.0D0 
        do k=1,3
          expfac=expfac+Ax(k,j)*z(k)
        enddo
        contr(j)=expfac
      enddo ! j

C As in the case of ebend, we want to avoid underflows in exponentiation and
C subsequent NaNs and INFs in energy calculation.
C Find the largest exponent
      emin=contr(1)
      do j=1,nlobit
        if (emin.gt.contr(j)) emin=contr(j)
      enddo 
      emin=0.5D0*emin
 
C Compute the contribution to SC energy and derivatives

      dersc12=0.0d0
      do j=1,nlobit
        expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
        escloc_i=escloc_i+expfac
        do k=1,2
          dersc(k)=dersc(k)+Ax(k,j)*expfac
        enddo
        if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
     &            +gaussc(1,2,j,it))*expfac
        dersc(3)=0.0d0
      enddo

      dersc(1)=dersc(1)/cos(theti)**2
      dersc12=dersc12/cos(theti)**2
      escloci=-(dlog(escloc_i)-emin)
      do j=1,2
        dersc(j)=dersc(j)/escloc_i
      enddo
      if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
      return
      end
#else
c----------------------------------------------------------------------------------
      subroutine esc(escloc)
C Calculate the local energy of a side chain and its derivatives in the
C corresponding virtual-bond valence angles THETA and the spherical angles 
C ALPHA and OMEGA derived from AM1 all-atom calculations.
C added by Urszula Kozlowska. 07/11/2007
C
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.GEO'
      include 'COMMON.LOCAL'
      include 'COMMON.VAR'
      include 'COMMON.SCROT'
      include 'COMMON.INTERACT'
      include 'COMMON.DERIV'
      include 'COMMON.CHAIN'
      include 'COMMON.IOUNITS'
      include 'COMMON.NAMES'
      include 'COMMON.FFIELD'
      include 'COMMON.CONTROL'
      include 'COMMON.VECTORS'
      double precision x_prime(3),y_prime(3),z_prime(3)
     &    , sumene,dsc_i,dp2_i,x(65),
     &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
     &    de_dxx,de_dyy,de_dzz,de_dt
      double precision s1_t,s1_6_t,s2_t,s2_6_t
      double precision 
     & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
     & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
     & dt_dCi(3),dt_dCi1(3)
      common /sccalc/ time11,time12,time112,theti,it,nlobit
      delta=0.02d0*pi
      escloc=0.0D0
      do i=loc_start,loc_end
        if (itype(i).eq.ntyp1) cycle
        costtab(i+1) =dcos(theta(i+1))
        sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
        cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
        sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
        cosfac2=0.5d0/(1.0d0+costtab(i+1))
        cosfac=dsqrt(cosfac2)
        sinfac2=0.5d0/(1.0d0-costtab(i+1))
        sinfac=dsqrt(sinfac2)
        it=iabs(itype(i))
        if (it.eq.10) goto 1
c
C  Compute the axes of tghe local cartesian coordinates system; store in
c   x_prime, y_prime and z_prime 
c
        do j=1,3
          x_prime(j) = 0.00
          y_prime(j) = 0.00
          z_prime(j) = 0.00
        enddo
C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
C     &   dc_norm(3,i+nres)
        do j = 1,3
          x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
          y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
        enddo
        do j = 1,3
          z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
        enddo     
c       write (2,*) "i",i
c       write (2,*) "x_prime",(x_prime(j),j=1,3)
c       write (2,*) "y_prime",(y_prime(j),j=1,3)
c       write (2,*) "z_prime",(z_prime(j),j=1,3)
c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
c      & " xy",scalar(x_prime(1),y_prime(1)),
c      & " xz",scalar(x_prime(1),z_prime(1)),
c      & " yy",scalar(y_prime(1),y_prime(1)),
c      & " yz",scalar(y_prime(1),z_prime(1)),
c      & " zz",scalar(z_prime(1),z_prime(1))
c
C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
C to local coordinate system. Store in xx, yy, zz.
c
        xx=0.0d0
        yy=0.0d0
        zz=0.0d0
        do j = 1,3
          xx = xx + x_prime(j)*dc_norm(j,i+nres)
          yy = yy + y_prime(j)*dc_norm(j,i+nres)
          zz = zz + z_prime(j)*dc_norm(j,i+nres)
        enddo

        xxtab(i)=xx
        yytab(i)=yy
        zztab(i)=zz
C
C Compute the energy of the ith side cbain
C
c        write (2,*) "xx",xx," yy",yy," zz",zz
        it=iabs(itype(i))
        do j = 1,65
          x(j) = sc_parmin(j,it) 
        enddo
#ifdef CHECK_COORD
Cc diagnostics - remove later
        xx1 = dcos(alph(2))
        yy1 = dsin(alph(2))*dcos(omeg(2))
c        zz1 = -dsin(alph(2))*dsin(omeg(2))
        zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
        write(2,'(3f8.1,3f9.3,1x,3f9.3)') 
     &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
     &    xx1,yy1,zz1
C,"  --- ", xx_w,yy_w,zz_w
c end diagnostics
#endif
        sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
     &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
     &   + x(10)*yy*zz
        sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
     & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
     & + x(20)*yy*zz
        sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
     &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
     &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
     &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
     &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
     &  +x(40)*xx*yy*zz
        sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
     &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
     &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
     &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
     &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
     &  +x(60)*xx*yy*zz
        dsc_i   = 0.743d0+x(61)
        dp2_i   = 1.9d0+x(62)
        dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
     &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
        dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
     &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
        s1=(1+x(63))/(0.1d0 + dscp1)
        s1_6=(1+x(64))/(0.1d0 + dscp1**6)
        s2=(1+x(65))/(0.1d0 + dscp2)
        s2_6=(1+x(65))/(0.1d0 + dscp2**6)
        sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
     & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
c     &   sumene4,
c     &   dscp1,dscp2,sumene
c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
        escloc = escloc + sumene
c        write (2,*) "escloc",escloc
        if (.not. calc_grad) goto 1
#ifdef DEBUG
C
C This section to check the numerical derivatives of the energy of ith side
C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
C #define DEBUG in the code to turn it on.
C
        write (2,*) "sumene               =",sumene
        aincr=1.0d-7
        xxsave=xx
        xx=xx+aincr
        write (2,*) xx,yy,zz
        sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
        de_dxx_num=(sumenep-sumene)/aincr
        xx=xxsave
        write (2,*) "xx+ sumene from enesc=",sumenep
        yysave=yy
        yy=yy+aincr
        write (2,*) xx,yy,zz
        sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
        de_dyy_num=(sumenep-sumene)/aincr
        yy=yysave
        write (2,*) "yy+ sumene from enesc=",sumenep
        zzsave=zz
        zz=zz+aincr
        write (2,*) xx,yy,zz
        sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
        de_dzz_num=(sumenep-sumene)/aincr
        zz=zzsave
        write (2,*) "zz+ sumene from enesc=",sumenep
        costsave=cost2tab(i+1)
        sintsave=sint2tab(i+1)
        cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
        sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
        sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
        de_dt_num=(sumenep-sumene)/aincr
        write (2,*) " t+ sumene from enesc=",sumenep
        cost2tab(i+1)=costsave
        sint2tab(i+1)=sintsave
C End of diagnostics section.
#endif
C        
C Compute the gradient of esc
C
        pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
        pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
        pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
        pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
        pom_dx=dsc_i*dp2_i*cost2tab(i+1)
        pom_dy=dsc_i*dp2_i*sint2tab(i+1)
        pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
        pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
        pom1=(sumene3*sint2tab(i+1)+sumene1)
     &     *(pom_s1/dscp1+pom_s16*dscp1**4)
        pom2=(sumene4*cost2tab(i+1)+sumene2)
     &     *(pom_s2/dscp2+pom_s26*dscp2**4)
        sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
        sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
     &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
     &  +x(40)*yy*zz
        sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
        sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
     &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
     &  +x(60)*yy*zz
        de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
     &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
     &        +(pom1+pom2)*pom_dx
#ifdef DEBUG
        write(2,*), "de_dxx = ", de_dxx,de_dxx_num
#endif
C
        sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
        sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
     &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
     &  +x(40)*xx*zz
        sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
        sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
     &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
     &  +x(59)*zz**2 +x(60)*xx*zz
        de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
     &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
     &        +(pom1-pom2)*pom_dy
#ifdef DEBUG
        write(2,*), "de_dyy = ", de_dyy,de_dyy_num
#endif
C
        de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
     &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx 
     &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) 
     &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) 
     &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2   
     &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy  
     &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
     &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
#ifdef DEBUG
        write(2,*), "de_dzz = ", de_dzz,de_dzz_num
#endif
C
        de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) 
     &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
     &  +pom1*pom_dt1+pom2*pom_dt2
#ifdef DEBUG
        write(2,*), "de_dt = ", de_dt,de_dt_num
#endif
c 
C
       cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
       cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
       cosfac2xx=cosfac2*xx
       sinfac2yy=sinfac2*yy
       do k = 1,3
         dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
     &      vbld_inv(i+1)
         dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
     &      vbld_inv(i)
         pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
         pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
         dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
         dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
         dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
         dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
         dZZ_Ci1(k)=0.0d0
         dZZ_Ci(k)=0.0d0
         do j=1,3
           dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
     &      *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
           dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
     & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
         enddo
          
         dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
         dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
         dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
c
         dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
         dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
       enddo

       do k=1,3
         dXX_Ctab(k,i)=dXX_Ci(k)
         dXX_C1tab(k,i)=dXX_Ci1(k)
         dYY_Ctab(k,i)=dYY_Ci(k)
         dYY_C1tab(k,i)=dYY_Ci1(k)
         dZZ_Ctab(k,i)=dZZ_Ci(k)
         dZZ_C1tab(k,i)=dZZ_Ci1(k)
         dXX_XYZtab(k,i)=dXX_XYZ(k)
         dYY_XYZtab(k,i)=dYY_XYZ(k)
         dZZ_XYZtab(k,i)=dZZ_XYZ(k)
       enddo

       do k = 1,3
c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
c     &    dt_dci(k)
c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) 
         gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
     &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
         gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
     &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
         gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
     &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
       enddo
c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)  

C to check gradient call subroutine check_grad

    1 continue
      enddo
      return
      end
#endif
c------------------------------------------------------------------------------
      subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
C
C This procedure calculates two-body contact function g(rij) and its derivative:
C
C           eps0ij                                     !       x < -1
C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
C            0                                         !       x > 1
C
C where x=(rij-r0ij)/delta
C
C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
C
      implicit none
      double precision rij,r0ij,eps0ij,fcont,fprimcont
      double precision x,x2,x4,delta
c     delta=0.02D0*r0ij
c      delta=0.2D0*r0ij
      x=(rij-r0ij)/delta
      if (x.lt.-1.0D0) then
        fcont=eps0ij
        fprimcont=0.0D0
      else if (x.le.1.0D0) then  
        x2=x*x
        x4=x2*x2
        fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
        fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
      else
        fcont=0.0D0
        fprimcont=0.0D0
      endif
      return
      end
c------------------------------------------------------------------------------
      subroutine splinthet(theti,delta,ss,ssder)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.VAR'
      include 'COMMON.GEO'
      thetup=pi-delta
      thetlow=delta
      if (theti.gt.pipol) then
        call gcont(theti,thetup,1.0d0,delta,ss,ssder)
      else
        call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
        ssder=-ssder
      endif
      return
      end
c------------------------------------------------------------------------------
      subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
      implicit none
      double precision x,x0,delta,f0,f1,fprim0,f,fprim
      double precision ksi,ksi2,ksi3,a1,a2,a3
      a1=fprim0*delta/(f1-f0)
      a2=3.0d0-2.0d0*a1
      a3=a1-2.0d0
      ksi=(x-x0)/delta
      ksi2=ksi*ksi
      ksi3=ksi2*ksi  
      f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
      fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
      return
      end
c------------------------------------------------------------------------------
      subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
      implicit none
      double precision x,x0,delta,f0x,f1x,fprim0x,fx
      double precision ksi,ksi2,ksi3,a1,a2,a3
      ksi=(x-x0)/delta  
      ksi2=ksi*ksi
      ksi3=ksi2*ksi
      a1=fprim0x*delta
      a2=3*(f1x-f0x)-2*fprim0x*delta
      a3=fprim0x*delta-2*(f1x-f0x)
      fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
      return
      end
C-----------------------------------------------------------------------------
#ifdef CRYST_TOR
C-----------------------------------------------------------------------------
      subroutine etor(etors,edihcnstr,fact)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.VAR'
      include 'COMMON.GEO'
      include 'COMMON.LOCAL'
      include 'COMMON.TORSION'
      include 'COMMON.INTERACT'
      include 'COMMON.DERIV'
      include 'COMMON.CHAIN'
      include 'COMMON.NAMES'
      include 'COMMON.IOUNITS'
      include 'COMMON.FFIELD'
      include 'COMMON.TORCNSTR'
      logical lprn
C Set lprn=.true. for debugging
      lprn=.false.
c      lprn=.true.
      etors=0.0D0
      do i=iphi_start,iphi_end
        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
     &      .or. itype(i).eq.ntyp1) cycle
	itori=itortyp(itype(i-2))
	itori1=itortyp(itype(i-1))
        phii=phi(i)
        gloci=0.0D0
C Proline-Proline pair is a special case...
        if (itori.eq.3 .and. itori1.eq.3) then
          if (phii.gt.-dwapi3) then
            cosphi=dcos(3*phii)
            fac=1.0D0/(1.0D0-cosphi)
            etorsi=v1(1,3,3)*fac
            etorsi=etorsi+etorsi
            etors=etors+etorsi-v1(1,3,3)
            gloci=gloci-3*fac*etorsi*dsin(3*phii)
          endif
          do j=1,3
            v1ij=v1(j+1,itori,itori1)
            v2ij=v2(j+1,itori,itori1)
            cosphi=dcos(j*phii)
            sinphi=dsin(j*phii)
            etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
          enddo
        else 
          do j=1,nterm_old
            v1ij=v1(j,itori,itori1)
            v2ij=v2(j,itori,itori1)
            cosphi=dcos(j*phii)
            sinphi=dsin(j*phii)
            etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
          enddo
        endif
        if (lprn)
     &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
     &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
     &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
        gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
      enddo
! 6/20/98 - dihedral angle constraints
      edihcnstr=0.0d0
      do i=1,ndih_constr
        itori=idih_constr(i)
        phii=phi(itori)
        difi=phii-phi0(i)
        if (difi.gt.drange(i)) then
          difi=difi-drange(i)
          edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
          gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
        else if (difi.lt.-drange(i)) then
          difi=difi+drange(i)
          edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
          gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
        endif
!        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
!     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
      enddo
!      write (iout,*) 'edihcnstr',edihcnstr
      return
      end
c------------------------------------------------------------------------------
#else
      subroutine etor(etors,edihcnstr,fact)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.VAR'
      include 'COMMON.GEO'
      include 'COMMON.LOCAL'
      include 'COMMON.TORSION'
      include 'COMMON.INTERACT'
      include 'COMMON.DERIV'
      include 'COMMON.CHAIN'
      include 'COMMON.NAMES'
      include 'COMMON.IOUNITS'
      include 'COMMON.FFIELD'
      include 'COMMON.TORCNSTR'
      logical lprn
C Set lprn=.true. for debugging
      lprn=.false.
c      lprn=.true.
      etors=0.0D0
      do i=iphi_start,iphi_end
        if (i.le.2) cycle
        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
     &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
        if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
         if (iabs(itype(i)).eq.20) then
         iblock=2
         else
         iblock=1
         endif
        itori=itortyp(itype(i-2))
        itori1=itortyp(itype(i-1))
        phii=phi(i)
        gloci=0.0D0
C Regular cosine and sine terms
        do j=1,nterm(itori,itori1,iblock)
          v1ij=v1(j,itori,itori1,iblock)
          v2ij=v2(j,itori,itori1,iblock)
          cosphi=dcos(j*phii)
          sinphi=dsin(j*phii)
          etors=etors+v1ij*cosphi+v2ij*sinphi
          gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
        enddo
C Lorentz terms
C                         v1
C  E = SUM ----------------------------------- - v1
C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
C
        cosphi=dcos(0.5d0*phii)
        sinphi=dsin(0.5d0*phii)
        do j=1,nlor(itori,itori1,iblock)
          vl1ij=vlor1(j,itori,itori1)
          vl2ij=vlor2(j,itori,itori1)
          vl3ij=vlor3(j,itori,itori1)
          pom=vl2ij*cosphi+vl3ij*sinphi
          pom1=1.0d0/(pom*pom+1.0d0)
          etors=etors+vl1ij*pom1
          pom=-pom*pom1*pom1
          gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
        enddo
C Subtract the constant term
        etors=etors-v0(itori,itori1,iblock)
        if (lprn)
     &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
     &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
     &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
        gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
 1215   continue
      enddo
! 6/20/98 - dihedral angle constraints
      edihcnstr=0.0d0
      do i=1,ndih_constr
        itori=idih_constr(i)
        phii=phi(itori)
        difi=pinorm(phii-phi0(i))
        edihi=0.0d0
        if (difi.gt.drange(i)) then
          difi=difi-drange(i)
          edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
          gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
          edihi=0.25d0*ftors(i)*difi**4
        else if (difi.lt.-drange(i)) then
          difi=difi+drange(i)
          edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
          gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
          edihi=0.25d0*ftors(i)*difi**4
        else
          difi=0.0d0
        endif
c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
c     &    drange(i),edihi
!        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
!     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
      enddo
!      write (iout,*) 'edihcnstr',edihcnstr
      return
      end
c----------------------------------------------------------------------------
      subroutine etor_d(etors_d,fact2)
C 6/23/01 Compute double torsional energy
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.VAR'
      include 'COMMON.GEO'
      include 'COMMON.LOCAL'
      include 'COMMON.TORSION'
      include 'COMMON.INTERACT'
      include 'COMMON.DERIV'
      include 'COMMON.CHAIN'
      include 'COMMON.NAMES'
      include 'COMMON.IOUNITS'
      include 'COMMON.FFIELD'
      include 'COMMON.TORCNSTR'
      logical lprn
C Set lprn=.true. for debugging
      lprn=.false.
c     lprn=.true.
      etors_d=0.0D0
      do i=iphi_start,iphi_end-1
        if (i.le.3) cycle
         if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
     &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
     &  (itype(i+1).eq.ntyp1)) cycle
        if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0) 
     &     goto 1215
        itori=itortyp(itype(i-2))
        itori1=itortyp(itype(i-1))
        itori2=itortyp(itype(i))
        phii=phi(i)
        phii1=phi(i+1)
        gloci1=0.0D0
        gloci2=0.0D0
        iblock=1
        if (iabs(itype(i+1)).eq.20) iblock=2
C Regular cosine and sine terms
       do j=1,ntermd_1(itori,itori1,itori2,iblock)
          v1cij=v1c(1,j,itori,itori1,itori2,iblock)
          v1sij=v1s(1,j,itori,itori1,itori2,iblock)
          v2cij=v1c(2,j,itori,itori1,itori2,iblock)
          v2sij=v1s(2,j,itori,itori1,itori2,iblock)
          cosphi1=dcos(j*phii)
          sinphi1=dsin(j*phii)
          cosphi2=dcos(j*phii1)
          sinphi2=dsin(j*phii1)
          etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
     &     v2cij*cosphi2+v2sij*sinphi2
          gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
          gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
        enddo
        do k=2,ntermd_2(itori,itori1,itori2,iblock)
          do l=1,k-1
            v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
            v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
            v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
            v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
            cosphi1p2=dcos(l*phii+(k-l)*phii1)
            cosphi1m2=dcos(l*phii-(k-l)*phii1)
            sinphi1p2=dsin(l*phii+(k-l)*phii1)
            sinphi1m2=dsin(l*phii-(k-l)*phii1)
            etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
     &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
            gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
     &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
            gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
     &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2) 
          enddo
        enddo
        gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
        gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
 1215   continue
      enddo
      return
      end
#endif
c------------------------------------------------------------------------------
      subroutine eback_sc_corr(esccor)
c 7/21/2007 Correlations between the backbone-local and side-chain-local
c        conformational states; temporarily implemented as differences
c        between UNRES torsional potentials (dependent on three types of
c        residues) and the torsional potentials dependent on all 20 types
c        of residues computed from AM1 energy surfaces of terminally-blocked
c        amino-acid residues.
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.VAR'
      include 'COMMON.GEO'
      include 'COMMON.LOCAL'
      include 'COMMON.TORSION'
      include 'COMMON.SCCOR'
      include 'COMMON.INTERACT'
      include 'COMMON.DERIV'
      include 'COMMON.CHAIN'
      include 'COMMON.NAMES'
      include 'COMMON.IOUNITS'
      include 'COMMON.FFIELD'
      include 'COMMON.CONTROL'
      logical lprn
C Set lprn=.true. for debugging
      lprn=.false.
c      lprn=.true.
c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
      esccor=0.0D0
      do i=itau_start,itau_end
        if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
        esccor_ii=0.0D0
        isccori=isccortyp(itype(i-2))
        isccori1=isccortyp(itype(i-1))
        phii=phi(i)
        do intertyp=1,3 !intertyp
cc Added 09 May 2012 (Adasko)
cc  Intertyp means interaction type of backbone mainchain correlation: 
c   1 = SC...Ca...Ca...Ca
c   2 = Ca...Ca...Ca...SC
c   3 = SC...Ca...Ca...SCi
        gloci=0.0D0
        if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
     &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
     &      (itype(i-1).eq.ntyp1)))
     &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
     &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
     &     .or.(itype(i).eq.ntyp1)))
     &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
     &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
     &      (itype(i-3).eq.ntyp1)))) cycle
        if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
        if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
     & cycle
       do j=1,nterm_sccor(isccori,isccori1)
          v1ij=v1sccor(j,intertyp,isccori,isccori1)
          v2ij=v2sccor(j,intertyp,isccori,isccori1)
          cosphi=dcos(j*tauangle(intertyp,i))
          sinphi=dsin(j*tauangle(intertyp,i))
           esccor=esccor+v1ij*cosphi+v2ij*sinphi
c           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
         enddo
c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
c      gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+wsccor*gloci
        if (lprn)
     &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
     &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
     &  (v1sccor(j,1,itori,itori1),j=1,6),
     &  (v2sccor(j,1,itori,itori1),j=1,6)
        gsccor_loc(i-3)=gloci
       enddo !intertyp
      enddo
      return
      end
c------------------------------------------------------------------------------
      subroutine multibody(ecorr)
C This subroutine calculates multi-body contributions to energy following
C the idea of Skolnick et al. If side chains I and J make a contact and
C at the same time side chains I+1 and J+1 make a contact, an extra 
C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'COMMON.IOUNITS'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      double precision gx(3),gx1(3)
      logical lprn

C Set lprn=.true. for debugging
      lprn=.false.

      if (lprn) then
        write (iout,'(a)') 'Contact function values:'
        do i=nnt,nct-2
          write (iout,'(i2,20(1x,i2,f10.5))') 
     &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
        enddo
      endif
      ecorr=0.0D0
      do i=nnt,nct
        do j=1,3
          gradcorr(j,i)=0.0D0
          gradxorr(j,i)=0.0D0
        enddo
      enddo
      do i=nnt,nct-2

        DO ISHIFT = 3,4

        i1=i+ishift
        num_conti=num_cont(i)
        num_conti1=num_cont(i1)
        do jj=1,num_conti
          j=jcont(jj,i)
          do kk=1,num_conti1
            j1=jcont(kk,i1)
            if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
cd   &                   ' ishift=',ishift
C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. 
C The system gains extra energy.
              ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
            endif   ! j1==j+-ishift
          enddo     ! kk  
        enddo       ! jj

        ENDDO ! ISHIFT

      enddo         ! i
      return
      end
c------------------------------------------------------------------------------
      double precision function esccorr(i,j,k,l,jj,kk)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'COMMON.IOUNITS'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      double precision gx(3),gx1(3)
      logical lprn
      lprn=.false.
      eij=facont(jj,i)
      ekl=facont(kk,k)
cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
C Calculate the multi-body contribution to energy.
C Calculate multi-body contributions to the gradient.
cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
cd   & k,l,(gacont(m,kk,k),m=1,3)
      do m=1,3
        gx(m) =ekl*gacont(m,jj,i)
        gx1(m)=eij*gacont(m,kk,k)
        gradxorr(m,i)=gradxorr(m,i)-gx(m)
        gradxorr(m,j)=gradxorr(m,j)+gx(m)
        gradxorr(m,k)=gradxorr(m,k)-gx1(m)
        gradxorr(m,l)=gradxorr(m,l)+gx1(m)
      enddo
      do m=i,j-1
        do ll=1,3
          gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
        enddo
      enddo
      do m=k,l-1
        do ll=1,3
          gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
        enddo
      enddo 
      esccorr=-eij*ekl
      return
      end
c------------------------------------------------------------------------------
#ifdef MPL
      subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS' 
      integer dimen1,dimen2,atom,indx
      double precision buffer(dimen1,dimen2)
      double precision zapas 
      common /contacts_hb/ zapas(3,20,maxres,7),
     &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
     &         num_cont_hb(maxres),jcont_hb(20,maxres)
      num_kont=num_cont_hb(atom)
      do i=1,num_kont
        do k=1,7
          do j=1,3
            buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
          enddo ! j
        enddo ! k
        buffer(i,indx+22)=facont_hb(i,atom)
        buffer(i,indx+23)=ees0p(i,atom)
        buffer(i,indx+24)=ees0m(i,atom)
        buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
      enddo ! i
      buffer(1,indx+26)=dfloat(num_kont)
      return
      end
c------------------------------------------------------------------------------
      subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS' 
      integer dimen1,dimen2,atom,indx
      double precision buffer(dimen1,dimen2)
      double precision zapas 
      common /contacts_hb/ zapas(3,ntyp,maxres,7),
     &     facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
     &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
      num_kont=buffer(1,indx+26)
      num_kont_old=num_cont_hb(atom)
      num_cont_hb(atom)=num_kont+num_kont_old
      do i=1,num_kont
        ii=i+num_kont_old
        do k=1,7    
          do j=1,3
            zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
          enddo ! j 
        enddo ! k 
        facont_hb(ii,atom)=buffer(i,indx+22)
        ees0p(ii,atom)=buffer(i,indx+23)
        ees0m(ii,atom)=buffer(i,indx+24)
        jcont_hb(ii,atom)=buffer(i,indx+25)
      enddo ! i
      return
      end
c------------------------------------------------------------------------------
#endif
      subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
C This subroutine calculates multi-body contributions to hydrogen-bonding 
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
#ifdef MPL
      include 'COMMON.INFO'
#endif
      include 'COMMON.FFIELD'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
#ifdef MPL
      parameter (max_cont=maxconts)
      parameter (max_dim=2*(8*3+2))
      parameter (msglen1=max_cont*max_dim*4)
      parameter (msglen2=2*msglen1)
      integer source,CorrelType,CorrelID,Error
      double precision buffer(max_cont,max_dim)
#endif
      double precision gx(3),gx1(3)
      logical lprn,ldone

C Set lprn=.true. for debugging
      lprn=.false.
#ifdef MPL
      n_corr=0
      n_corr1=0
      if (fgProcs.le.1) goto 30
      if (lprn) then
        write (iout,'(a)') 'Contact function values:'
        do i=nnt,nct-2
          write (iout,'(2i3,50(1x,i2,f5.2))') 
     &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
     &    j=1,num_cont_hb(i))
        enddo
      endif
C Caution! Following code assumes that electrostatic interactions concerning
C a given atom are split among at most two processors!
      CorrelType=477
      CorrelID=MyID+1
      ldone=.false.
      do i=1,max_cont
        do j=1,max_dim
          buffer(i,j)=0.0D0
        enddo
      enddo
      mm=mod(MyRank,2)
cd    write (iout,*) 'MyRank',MyRank,' mm',mm
      if (mm) 20,20,10 
   10 continue
cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
      if (MyRank.gt.0) then
C Send correlation contributions to the preceding processor
        msglen=msglen1
        nn=num_cont_hb(iatel_s)
        call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
cd      write (iout,*) 'The BUFFER array:'
cd      do i=1,nn
cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
cd      enddo
        if (ielstart(iatel_s).gt.iatel_s+ispp) then
          msglen=msglen2
            call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
C Clear the contacts of the atom passed to the neighboring processor
        nn=num_cont_hb(iatel_s+1)
cd      do i=1,nn
cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
cd      enddo
            num_cont_hb(iatel_s)=0
        endif 
cd      write (iout,*) 'Processor ',MyID,MyRank,
cd   & ' is sending correlation contribution to processor',MyID-1,
cd   & ' msglen=',msglen
cd      write (*,*) 'Processor ',MyID,MyRank,
cd   & ' is sending correlation contribution to processor',MyID-1,
cd   & ' msglen=',msglen,' CorrelType=',CorrelType
        call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
cd      write (iout,*) 'Processor ',MyID,
cd   & ' has sent correlation contribution to processor',MyID-1,
cd   & ' msglen=',msglen,' CorrelID=',CorrelID
cd      write (*,*) 'Processor ',MyID,
cd   & ' has sent correlation contribution to processor',MyID-1,
cd   & ' msglen=',msglen,' CorrelID=',CorrelID
        msglen=msglen1
      endif ! (MyRank.gt.0)
      if (ldone) goto 30
      ldone=.true.
   20 continue
cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
      if (MyRank.lt.fgProcs-1) then
C Receive correlation contributions from the next processor
        msglen=msglen1
        if (ielend(iatel_e).lt.nct-1) msglen=msglen2
cd      write (iout,*) 'Processor',MyID,
cd   & ' is receiving correlation contribution from processor',MyID+1,
cd   & ' msglen=',msglen,' CorrelType=',CorrelType
cd      write (*,*) 'Processor',MyID,
cd   & ' is receiving correlation contribution from processor',MyID+1,
cd   & ' msglen=',msglen,' CorrelType=',CorrelType
        nbytes=-1
        do while (nbytes.le.0)
          call mp_probe(MyID+1,CorrelType,nbytes)
        enddo
cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
        call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
cd      write (iout,*) 'Processor',MyID,
cd   & ' has received correlation contribution from processor',MyID+1,
cd   & ' msglen=',msglen,' nbytes=',nbytes
cd      write (iout,*) 'The received BUFFER array:'
cd      do i=1,max_cont
cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
cd      enddo
        if (msglen.eq.msglen1) then
          call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
        else if (msglen.eq.msglen2)  then
          call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer) 
          call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer) 
        else
          write (iout,*) 
     & 'ERROR!!!! message length changed while processing correlations.'
          write (*,*) 
     & 'ERROR!!!! message length changed while processing correlations.'
          call mp_stopall(Error)
        endif ! msglen.eq.msglen1
      endif ! MyRank.lt.fgProcs-1
      if (ldone) goto 30
      ldone=.true.
      goto 10
   30 continue
#endif
      if (lprn) then
        write (iout,'(a)') 'Contact function values:'
        do i=nnt,nct-2
          write (iout,'(2i3,50(1x,i2,f5.2))') 
     &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
     &    j=1,num_cont_hb(i))
        enddo
      endif
      ecorr=0.0D0
C Remove the loop below after debugging !!!
      do i=nnt,nct
        do j=1,3
          gradcorr(j,i)=0.0D0
          gradxorr(j,i)=0.0D0
        enddo
      enddo
C Calculate the local-electrostatic correlation terms
      do i=iatel_s,iatel_e+1
        i1=i+1
        num_conti=num_cont_hb(i)
        num_conti1=num_cont_hb(i+1)
        do jj=1,num_conti
          j=jcont_hb(jj,i)
          do kk=1,num_conti1
            j1=jcont_hb(kk,i1)
c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
c     &         ' jj=',jj,' kk=',kk
            if (j1.eq.j+1 .or. j1.eq.j-1) then
C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. 
C The system gains extra energy.
              ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
              n_corr=n_corr+1
            else if (j1.eq.j) then
C Contacts I-J and I-(J+1) occur simultaneously. 
C The system loses extra energy.
c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) 
            endif
          enddo ! kk
          do kk=1,num_conti
            j1=jcont_hb(kk,i)
c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
c    &         ' jj=',jj,' kk=',kk
            if (j1.eq.j+1) then
C Contacts I-J and (I+1)-J occur simultaneously. 
C The system loses extra energy.
c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
            endif ! j1==j+1
          enddo ! kk
        enddo ! jj
      enddo ! i
      return
      end
c------------------------------------------------------------------------------
      subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
     &  n_corr1)
C This subroutine calculates multi-body contributions to hydrogen-bonding 
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
#ifdef MPL
      include 'COMMON.INFO'
#endif
      include 'COMMON.FFIELD'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
#ifdef MPL
      parameter (max_cont=maxconts)
      parameter (max_dim=2*(8*3+2))
      parameter (msglen1=max_cont*max_dim*4)
      parameter (msglen2=2*msglen1)
      integer source,CorrelType,CorrelID,Error
      double precision buffer(max_cont,max_dim)
#endif
      double precision gx(3),gx1(3)
      logical lprn,ldone

C Set lprn=.true. for debugging
      lprn=.false.
      eturn6=0.0d0
#ifdef MPL
      n_corr=0
      n_corr1=0
      if (fgProcs.le.1) goto 30
      if (lprn) then
        write (iout,'(a)') 'Contact function values:'
        do i=nnt,nct-2
          write (iout,'(2i3,50(1x,i2,f5.2))') 
     &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
     &    j=1,num_cont_hb(i))
        enddo
      endif
C Caution! Following code assumes that electrostatic interactions concerning
C a given atom are split among at most two processors!
      CorrelType=477
      CorrelID=MyID+1
      ldone=.false.
      do i=1,max_cont
        do j=1,max_dim
          buffer(i,j)=0.0D0
        enddo
      enddo
      mm=mod(MyRank,2)
cd    write (iout,*) 'MyRank',MyRank,' mm',mm
      if (mm) 20,20,10 
   10 continue
cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
      if (MyRank.gt.0) then
C Send correlation contributions to the preceding processor
        msglen=msglen1
        nn=num_cont_hb(iatel_s)
        call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
cd      write (iout,*) 'The BUFFER array:'
cd      do i=1,nn
cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
cd      enddo
        if (ielstart(iatel_s).gt.iatel_s+ispp) then
          msglen=msglen2
            call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
C Clear the contacts of the atom passed to the neighboring processor
        nn=num_cont_hb(iatel_s+1)
cd      do i=1,nn
cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
cd      enddo
            num_cont_hb(iatel_s)=0
        endif 
cd      write (iout,*) 'Processor ',MyID,MyRank,
cd   & ' is sending correlation contribution to processor',MyID-1,
cd   & ' msglen=',msglen
cd      write (*,*) 'Processor ',MyID,MyRank,
cd   & ' is sending correlation contribution to processor',MyID-1,
cd   & ' msglen=',msglen,' CorrelType=',CorrelType
        call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
cd      write (iout,*) 'Processor ',MyID,
cd   & ' has sent correlation contribution to processor',MyID-1,
cd   & ' msglen=',msglen,' CorrelID=',CorrelID
cd      write (*,*) 'Processor ',MyID,
cd   & ' has sent correlation contribution to processor',MyID-1,
cd   & ' msglen=',msglen,' CorrelID=',CorrelID
        msglen=msglen1
      endif ! (MyRank.gt.0)
      if (ldone) goto 30
      ldone=.true.
   20 continue
cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
      if (MyRank.lt.fgProcs-1) then
C Receive correlation contributions from the next processor
        msglen=msglen1
        if (ielend(iatel_e).lt.nct-1) msglen=msglen2
cd      write (iout,*) 'Processor',MyID,
cd   & ' is receiving correlation contribution from processor',MyID+1,
cd   & ' msglen=',msglen,' CorrelType=',CorrelType
cd      write (*,*) 'Processor',MyID,
cd   & ' is receiving correlation contribution from processor',MyID+1,
cd   & ' msglen=',msglen,' CorrelType=',CorrelType
        nbytes=-1
        do while (nbytes.le.0)
          call mp_probe(MyID+1,CorrelType,nbytes)
        enddo
cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
        call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
cd      write (iout,*) 'Processor',MyID,
cd   & ' has received correlation contribution from processor',MyID+1,
cd   & ' msglen=',msglen,' nbytes=',nbytes
cd      write (iout,*) 'The received BUFFER array:'
cd      do i=1,max_cont
cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
cd      enddo
        if (msglen.eq.msglen1) then
          call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
        else if (msglen.eq.msglen2)  then
          call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer) 
          call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer) 
        else
          write (iout,*) 
     & 'ERROR!!!! message length changed while processing correlations.'
          write (*,*) 
     & 'ERROR!!!! message length changed while processing correlations.'
          call mp_stopall(Error)
        endif ! msglen.eq.msglen1
      endif ! MyRank.lt.fgProcs-1
      if (ldone) goto 30
      ldone=.true.
      goto 10
   30 continue
#endif
      if (lprn) then
        write (iout,'(a)') 'Contact function values:'
        do i=nnt,nct-2
          write (iout,'(2i3,50(1x,i2,f5.2))') 
     &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
     &    j=1,num_cont_hb(i))
        enddo
      endif
      ecorr=0.0D0
      ecorr5=0.0d0
      ecorr6=0.0d0
C Remove the loop below after debugging !!!
      do i=nnt,nct
        do j=1,3
          gradcorr(j,i)=0.0D0
          gradxorr(j,i)=0.0D0
        enddo
      enddo
C Calculate the dipole-dipole interaction energies
      if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
      do i=iatel_s,iatel_e+1
        num_conti=num_cont_hb(i)
        do jj=1,num_conti
          j=jcont_hb(jj,i)
          call dipole(i,j,jj)
        enddo
      enddo
      endif
C Calculate the local-electrostatic correlation terms
      do i=iatel_s,iatel_e+1
        i1=i+1
        num_conti=num_cont_hb(i)
        num_conti1=num_cont_hb(i+1)
        do jj=1,num_conti
          j=jcont_hb(jj,i)
          do kk=1,num_conti1
            j1=jcont_hb(kk,i1)
c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
c     &         ' jj=',jj,' kk=',kk
            if (j1.eq.j+1 .or. j1.eq.j-1) then
C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. 
C The system gains extra energy.
              n_corr=n_corr+1
              sqd1=dsqrt(d_cont(jj,i))
              sqd2=dsqrt(d_cont(kk,i1))
              sred_geom = sqd1*sqd2
              IF (sred_geom.lt.cutoff_corr) THEN
                call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
     &            ekont,fprimcont)
c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
c     &         ' jj=',jj,' kk=',kk
                fac_prim1=0.5d0*sqd2/sqd1*fprimcont
                fac_prim2=0.5d0*sqd1/sqd2*fprimcont
                do l=1,3
                  g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
                  g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
                enddo
                n_corr1=n_corr1+1
cd               write (iout,*) 'sred_geom=',sred_geom,
cd     &          ' ekont=',ekont,' fprim=',fprimcont
                call calc_eello(i,j,i+1,j1,jj,kk)
                if (wcorr4.gt.0.0d0) 
     &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
                if (wcorr5.gt.0.0d0)
     &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
c                print *,"wcorr5",ecorr5
cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
cd                write(2,*)'ijkl',i,j,i+1,j1 
                if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
     &               .or. wturn6.eq.0.0d0))then
cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
                  ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
cd     &            'ecorr6=',ecorr6
cd                write (iout,'(4e15.5)') sred_geom,
cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
                else if (wturn6.gt.0.0d0
     &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
                  eturn6=eturn6+eello_turn6(i,jj,kk)
cd                  write (2,*) 'multibody_eello:eturn6',eturn6
                endif
              ENDIF
1111          continue
            else if (j1.eq.j) then
C Contacts I-J and I-(J+1) occur simultaneously. 
C The system loses extra energy.
c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) 
            endif
          enddo ! kk
          do kk=1,num_conti
            j1=jcont_hb(kk,i)
c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
c    &         ' jj=',jj,' kk=',kk
            if (j1.eq.j+1) then
C Contacts I-J and (I+1)-J occur simultaneously. 
C The system loses extra energy.
c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
            endif ! j1==j+1
          enddo ! kk
        enddo ! jj
      enddo ! i
      return
      end
c------------------------------------------------------------------------------
      double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'COMMON.IOUNITS'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.SHIELD'

      double precision gx(3),gx1(3)
      logical lprn
      lprn=.false.
      eij=facont_hb(jj,i)
      ekl=facont_hb(kk,k)
      ees0pij=ees0p(jj,i)
      ees0pkl=ees0p(kk,k)
      ees0mij=ees0m(jj,i)
      ees0mkl=ees0m(kk,k)
      ekont=eij*ekl
      ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
C Following 4 lines for diagnostics.
cd    ees0pkl=0.0D0
cd    ees0pij=1.0D0
cd    ees0mkl=0.0D0
cd    ees0mij=1.0D0
c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
c    &   ' and',k,l
c     write (iout,*)'Contacts have occurred for peptide groups',
c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
C Calculate the multi-body contribution to energy.
      ecorr=ecorr+ekont*ees
      if (calc_grad) then
C Calculate multi-body contributions to the gradient.
      do ll=1,3
        ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
        gradcorr(ll,i)=gradcorr(ll,i)+ghalf
     &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
     &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
        gradcorr(ll,j)=gradcorr(ll,j)+ghalf
     &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
     &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
        ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
        gradcorr(ll,k)=gradcorr(ll,k)+ghalf
     &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
     &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
        gradcorr(ll,l)=gradcorr(ll,l)+ghalf
     &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
     &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
      enddo
      do m=i+1,j-1
        do ll=1,3
          gradcorr(ll,m)=gradcorr(ll,m)+
     &     ees*ekl*gacont_hbr(ll,jj,i)-
     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
        enddo
      enddo
      do m=k+1,l-1
        do ll=1,3
          gradcorr(ll,m)=gradcorr(ll,m)+
     &     ees*eij*gacont_hbr(ll,kk,k)-
     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
        enddo
      enddo
      if (shield_mode.gt.0) then
       j=ees0plist(jj,i)
       l=ees0plist(kk,k)
C        print *,i,j,fac_shield(i),fac_shield(j),
C     &fac_shield(k),fac_shield(l)
        if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
     &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
          do ilist=1,ishield_list(i)
           iresshield=shield_list(ilist,i)
           do m=1,3
           rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
C     &      *2.0
           gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
     &              rlocshield
     & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
     &+rlocshield
           enddo
          enddo
          do ilist=1,ishield_list(j)
           iresshield=shield_list(ilist,j)
           do m=1,3
           rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
C     &     *2.0
           gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
     &              rlocshield
     & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
           gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
     &     +rlocshield
           enddo
          enddo
          do ilist=1,ishield_list(k)
           iresshield=shield_list(ilist,k)
           do m=1,3
           rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
C     &     *2.0
           gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
     &              rlocshield
     & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
           gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
     &     +rlocshield
           enddo
          enddo
          do ilist=1,ishield_list(l)
           iresshield=shield_list(ilist,l)
           do m=1,3
           rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
C     &     *2.0
           gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
     &              rlocshield
     & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
           gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
     &     +rlocshield
           enddo
          enddo
C          print *,gshieldx(m,iresshield)
          do m=1,3
            gshieldc_ec(m,i)=gshieldc_ec(m,i)+
     &              grad_shield(m,i)*ehbcorr/fac_shield(i)
            gshieldc_ec(m,j)=gshieldc_ec(m,j)+
     &              grad_shield(m,j)*ehbcorr/fac_shield(j)
            gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
     &              grad_shield(m,i)*ehbcorr/fac_shield(i)
            gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
     &              grad_shield(m,j)*ehbcorr/fac_shield(j)

            gshieldc_ec(m,k)=gshieldc_ec(m,k)+
     &              grad_shield(m,k)*ehbcorr/fac_shield(k)
            gshieldc_ec(m,l)=gshieldc_ec(m,l)+
     &              grad_shield(m,l)*ehbcorr/fac_shield(l)
            gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
     &              grad_shield(m,k)*ehbcorr/fac_shield(k)
            gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
     &              grad_shield(m,l)*ehbcorr/fac_shield(l)

           enddo
      endif
      endif
      endif
      ehbcorr=ekont*ees
      return
      end
C---------------------------------------------------------------------------
      subroutine dipole(i,j,jj)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.FFIELD'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.TORSION'
      include 'COMMON.VAR'
      include 'COMMON.GEO'
      dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
     &  auxmat(2,2)
      iti1 = itortyp(itype(i+1))
      if (j.lt.nres-1) then
        if (itype(j).le.ntyp) then
          itj1 = itortyp(itype(j+1))
        else
          itj1=ntortyp+1
        endif
      else
        itj1=ntortyp+1
      endif
      do iii=1,2
        dipi(iii,1)=Ub2(iii,i)
        dipderi(iii)=Ub2der(iii,i)
        dipi(iii,2)=b1(iii,iti1)
        dipj(iii,1)=Ub2(iii,j)
        dipderj(iii)=Ub2der(iii,j)
        dipj(iii,2)=b1(iii,itj1)
      enddo
      kkk=0
      do iii=1,2
        call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) 
        do jjj=1,2
          kkk=kkk+1
          dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
        enddo
      enddo
      if (.not.calc_grad) return
      do kkk=1,5
        do lll=1,3
          mmm=0
          do iii=1,2
            call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
     &        auxvec(1))
            do jjj=1,2
              mmm=mmm+1
              dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
            enddo
          enddo
        enddo
      enddo
      call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
      call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
      do iii=1,2
        dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
      enddo
      call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
      do iii=1,2
        dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
      enddo
      return
      end
C---------------------------------------------------------------------------
      subroutine calc_eello(i,j,k,l,jj,kk)
C 
C This subroutine computes matrices and vectors needed to calculate 
C the fourth-, fifth-, and sixth-order local-electrostatic terms.
C
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.TORSION'
      include 'COMMON.VAR'
      include 'COMMON.GEO'
      include 'COMMON.FFIELD'
      double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
     &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
      logical lprn
      common /kutas/ lprn
cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
cd     & ' jj=',jj,' kk=',kk
cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
      do iii=1,2
        do jjj=1,2
          aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
          aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
        enddo
      enddo
      call transpose2(aa1(1,1),aa1t(1,1))
      call transpose2(aa2(1,1),aa2t(1,1))
      do kkk=1,5
        do lll=1,3
          call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
     &      aa1tder(1,1,lll,kkk))
          call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
     &      aa2tder(1,1,lll,kkk))
        enddo
      enddo 
      if (l.eq.j+1) then
C parallel orientation of the two CA-CA-CA frames.
c        if (i.gt.1) then
        if (i.gt.1 .and. itype(i).le.ntyp) then
          iti=itortyp(itype(i))
        else
          iti=ntortyp+1
        endif
        itk1=itortyp(itype(k+1))
        itj=itortyp(itype(j))
c        if (l.lt.nres-1) then
        if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
          itl1=itortyp(itype(l+1))
        else
          itl1=ntortyp+1
        endif
C A1 kernel(j+1) A2T
cd        do iii=1,2
cd          write (iout,'(3f10.5,5x,3f10.5)') 
cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
cd        enddo
        call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
     &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
     &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
C Following matrices are needed only for 6-th order cumulants
        IF (wcorr6.gt.0.0d0) THEN
        call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
     &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
     &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
        call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
     &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
     &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
     &   ADtEAderx(1,1,1,1,1,1))
        lprn=.false.
        call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
     &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
     &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
     &   ADtEA1derx(1,1,1,1,1,1))
        ENDIF
C End 6-th order cumulants
cd        lprn=.false.
cd        if (lprn) then
cd        write (2,*) 'In calc_eello6'
cd        do iii=1,2
cd          write (2,*) 'iii=',iii
cd          do kkk=1,5
cd            write (2,*) 'kkk=',kkk
cd            do jjj=1,2
cd              write (2,'(3(2f10.5),5x)') 
cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
cd            enddo
cd          enddo
cd        enddo
cd        endif
        call transpose2(EUgder(1,1,k),auxmat(1,1))
        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
        call transpose2(EUg(1,1,k),auxmat(1,1))
        call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
        call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
        do iii=1,2
          do kkk=1,5
            do lll=1,3
              call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
     &          EAEAderx(1,1,lll,kkk,iii,1))
            enddo
          enddo
        enddo
C A1T kernel(i+1) A2
        call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
     &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
     &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
C Following matrices are needed only for 6-th order cumulants
        IF (wcorr6.gt.0.0d0) THEN
        call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
     &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
     &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
        call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
     &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
     &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
     &   ADtEAderx(1,1,1,1,1,2))
        call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
     &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
     &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
     &   ADtEA1derx(1,1,1,1,1,2))
        ENDIF
C End 6-th order cumulants
        call transpose2(EUgder(1,1,l),auxmat(1,1))
        call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
        call transpose2(EUg(1,1,l),auxmat(1,1))
        call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
        call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
        do iii=1,2
          do kkk=1,5
            do lll=1,3
              call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
     &          EAEAderx(1,1,lll,kkk,iii,2))
            enddo
          enddo
        enddo
C AEAb1 and AEAb2
C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
C They are needed only when the fifth- or the sixth-order cumulants are
C indluded.
        IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
        call transpose2(AEA(1,1,1),auxmat(1,1))
        call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
        call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
        call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
        call transpose2(AEAderg(1,1,1),auxmat(1,1))
        call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
        call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
        call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
        call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
        call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
        call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
        call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
        call transpose2(AEA(1,1,2),auxmat(1,1))
        call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
        call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
        call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
        call transpose2(AEAderg(1,1,2),auxmat(1,1))
        call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
        call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
        call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
        call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
        call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
        call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
        call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
C Calculate the Cartesian derivatives of the vectors.
        do iii=1,2
          do kkk=1,5
            do lll=1,3
              call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
              call matvec2(auxmat(1,1),b1(1,iti),
     &          AEAb1derx(1,lll,kkk,iii,1,1))
              call matvec2(auxmat(1,1),Ub2(1,i),
     &          AEAb2derx(1,lll,kkk,iii,1,1))
              call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
     &          AEAb1derx(1,lll,kkk,iii,2,1))
              call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
     &          AEAb2derx(1,lll,kkk,iii,2,1))
              call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
              call matvec2(auxmat(1,1),b1(1,itj),
     &          AEAb1derx(1,lll,kkk,iii,1,2))
              call matvec2(auxmat(1,1),Ub2(1,j),
     &          AEAb2derx(1,lll,kkk,iii,1,2))
              call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
     &          AEAb1derx(1,lll,kkk,iii,2,2))
              call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
     &          AEAb2derx(1,lll,kkk,iii,2,2))
            enddo
          enddo
        enddo
        ENDIF
C End vectors
      else
C Antiparallel orientation of the two CA-CA-CA frames.
c        if (i.gt.1) then
        if (i.gt.1 .and. itype(i).le.ntyp) then
          iti=itortyp(itype(i))
        else
          iti=ntortyp+1
        endif
        itk1=itortyp(itype(k+1))
        itl=itortyp(itype(l))
        itj=itortyp(itype(j))
c        if (j.lt.nres-1) then
        if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
          itj1=itortyp(itype(j+1))
        else 
          itj1=ntortyp+1
        endif
C A2 kernel(j-1)T A1T
        call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
     &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
     &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
C Following matrices are needed only for 6-th order cumulants
        IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
     &     j.eq.i+4 .and. l.eq.i+3)) THEN
        call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
     &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
     &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
        call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
     &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
     &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
     &   ADtEAderx(1,1,1,1,1,1))
        call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
     &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
     &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
     &   ADtEA1derx(1,1,1,1,1,1))
        ENDIF
C End 6-th order cumulants
        call transpose2(EUgder(1,1,k),auxmat(1,1))
        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
        call transpose2(EUg(1,1,k),auxmat(1,1))
        call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
        call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
        do iii=1,2
          do kkk=1,5
            do lll=1,3
              call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
     &          EAEAderx(1,1,lll,kkk,iii,1))
            enddo
          enddo
        enddo
C A2T kernel(i+1)T A1
        call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
     &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
     &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
C Following matrices are needed only for 6-th order cumulants
        IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
     &     j.eq.i+4 .and. l.eq.i+3)) THEN
        call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
     &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
     &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
        call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
     &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
     &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
     &   ADtEAderx(1,1,1,1,1,2))
        call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
     &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
     &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
     &   ADtEA1derx(1,1,1,1,1,2))
        ENDIF
C End 6-th order cumulants
        call transpose2(EUgder(1,1,j),auxmat(1,1))
        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
        call transpose2(EUg(1,1,j),auxmat(1,1))
        call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
        call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
        do iii=1,2
          do kkk=1,5
            do lll=1,3
              call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
     &          EAEAderx(1,1,lll,kkk,iii,2))
            enddo
          enddo
        enddo
C AEAb1 and AEAb2
C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
C They are needed only when the fifth- or the sixth-order cumulants are
C indluded.
        IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
     &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
        call transpose2(AEA(1,1,1),auxmat(1,1))
        call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
        call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
        call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
        call transpose2(AEAderg(1,1,1),auxmat(1,1))
        call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
        call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
        call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
        call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
        call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
        call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
        call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
        call transpose2(AEA(1,1,2),auxmat(1,1))
        call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
        call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
        call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
        call transpose2(AEAderg(1,1,2),auxmat(1,1))
        call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
        call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
        call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
        call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
        call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
        call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
        call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
C Calculate the Cartesian derivatives of the vectors.
        do iii=1,2
          do kkk=1,5
            do lll=1,3
              call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
              call matvec2(auxmat(1,1),b1(1,iti),
     &          AEAb1derx(1,lll,kkk,iii,1,1))
              call matvec2(auxmat(1,1),Ub2(1,i),
     &          AEAb2derx(1,lll,kkk,iii,1,1))
              call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
     &          AEAb1derx(1,lll,kkk,iii,2,1))
              call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
     &          AEAb2derx(1,lll,kkk,iii,2,1))
              call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
              call matvec2(auxmat(1,1),b1(1,itl),
     &          AEAb1derx(1,lll,kkk,iii,1,2))
              call matvec2(auxmat(1,1),Ub2(1,l),
     &          AEAb2derx(1,lll,kkk,iii,1,2))
              call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
     &          AEAb1derx(1,lll,kkk,iii,2,2))
              call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
     &          AEAb2derx(1,lll,kkk,iii,2,2))
            enddo
          enddo
        enddo
        ENDIF
C End vectors
      endif
      return
      end
C---------------------------------------------------------------------------
      subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
     &  KK,KKderg,AKA,AKAderg,AKAderx)
      implicit none
      integer nderg
      logical transp
      double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
     &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
     &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
      integer iii,kkk,lll
      integer jjj,mmm
      logical lprn
      common /kutas/ lprn
      call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
      do iii=1,nderg 
        call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
     &    AKAderg(1,1,iii))
      enddo
cd      if (lprn) write (2,*) 'In kernel'
      do kkk=1,5
cd        if (lprn) write (2,*) 'kkk=',kkk
        do lll=1,3
          call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
     &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
cd          if (lprn) then
cd            write (2,*) 'lll=',lll
cd            write (2,*) 'iii=1'
cd            do jjj=1,2
cd              write (2,'(3(2f10.5),5x)') 
cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
cd            enddo
cd          endif
          call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
     &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
cd          if (lprn) then
cd            write (2,*) 'lll=',lll
cd            write (2,*) 'iii=2'
cd            do jjj=1,2
cd              write (2,'(3(2f10.5),5x)') 
cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
cd            enddo
cd          endif
        enddo
      enddo
      return
      end
C---------------------------------------------------------------------------
      double precision function eello4(i,j,k,l,jj,kk)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.TORSION'
      include 'COMMON.VAR'
      include 'COMMON.GEO'
      double precision pizda(2,2),ggg1(3),ggg2(3)
cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
cd        eello4=0.0d0
cd        return
cd      endif
cd      print *,'eello4:',i,j,k,l,jj,kk
cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
cold      eij=facont_hb(jj,i)
cold      ekl=facont_hb(kk,k)
cold      ekont=eij*ekl
      eel4=-EAEA(1,1,1)-EAEA(2,2,1)
      if (calc_grad) then
cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
      gcorr_loc(k-1)=gcorr_loc(k-1)
     &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
      if (l.eq.j+1) then
        gcorr_loc(l-1)=gcorr_loc(l-1)
     &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
      else
        gcorr_loc(j-1)=gcorr_loc(j-1)
     &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
      endif
      do iii=1,2
        do kkk=1,5
          do lll=1,3
            derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
     &                        -EAEAderx(2,2,lll,kkk,iii,1)
cd            derx(lll,kkk,iii)=0.0d0
          enddo
        enddo
      enddo
cd      gcorr_loc(l-1)=0.0d0
cd      gcorr_loc(j-1)=0.0d0
cd      gcorr_loc(k-1)=0.0d0
cd      eel4=1.0d0
cd      write (iout,*)'Contacts have occurred for peptide groups',
cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
      if (j.lt.nres-1) then
        j1=j+1
        j2=j-1
      else
        j1=j-1
        j2=j-2
      endif
      if (l.lt.nres-1) then
        l1=l+1
        l2=l-1
      else
        l1=l-1
        l2=l-2
      endif
      do ll=1,3
cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
        ggg1(ll)=eel4*g_contij(ll,1)
        ggg2(ll)=eel4*g_contij(ll,2)
        ghalf=0.5d0*ggg1(ll)
cd        ghalf=0.0d0
        gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
        gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
        gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
        gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
        ghalf=0.5d0*ggg2(ll)
cd        ghalf=0.0d0
        gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
        gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
        gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
        gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
      enddo
cd      goto 1112
      do m=i+1,j-1
        do ll=1,3
cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
        enddo
      enddo
      do m=k+1,l-1
        do ll=1,3
cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
        enddo
      enddo
1112  continue
      do m=i+2,j2
        do ll=1,3
          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
        enddo
      enddo
      do m=k+2,l2
        do ll=1,3
          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
        enddo
      enddo 
cd      do iii=1,nres-3
cd        write (2,*) iii,gcorr_loc(iii)
cd      enddo
      endif
      eello4=ekont*eel4
cd      write (2,*) 'ekont',ekont
cd      write (iout,*) 'eello4',ekont*eel4
      return
      end
C---------------------------------------------------------------------------
      double precision function eello5(i,j,k,l,jj,kk)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.TORSION'
      include 'COMMON.VAR'
      include 'COMMON.GEO'
      double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
      double precision ggg1(3),ggg2(3)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                              C
C                            Parallel chains                                   C
C                                                                              C
C          o             o                   o             o                   C
C         /l\           / \             \   / \           / \   /              C
C        /   \         /   \             \ /   \         /   \ /               C
C       j| o |l1       | o |	          o| o |         | o |o                C
C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
C      \i/   \         /   \ /             /   \         /   \                 C
C       o    k1             o                                                  C
C         (I)          (II)                (III)          (IV)                 C
C                                                                              C
C      eello5_1        eello5_2            eello5_3       eello5_4             C
C                                                                              C
C                            Antiparallel chains                               C
C                                                                              C
C          o             o                   o             o                   C
C         /j\           / \             \   / \           / \   /              C
C        /   \         /   \             \ /   \         /   \ /               C
C      j1| o |l        | o |	          o| o |         | o |o                C
C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
C      \i/   \         /   \ /             /   \         /   \                 C
C       o     k1            o                                                  C
C         (I)          (II)                (III)          (IV)                 C
C                                                                              C
C      eello5_1        eello5_2            eello5_3       eello5_4             C
C                                                                              C
C o denotes a local interaction, vertical lines an electrostatic interaction.  C
C                                                                              C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
cd        eello5=0.0d0
cd        return
cd      endif
cd      write (iout,*)
cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
cd     &   ' and',k,l
      itk=itortyp(itype(k))
      itl=itortyp(itype(l))
      itj=itortyp(itype(j))
      eello5_1=0.0d0
      eello5_2=0.0d0
      eello5_3=0.0d0
      eello5_4=0.0d0
cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
cd     &   eel5_3_num,eel5_4_num)
      do iii=1,2
        do kkk=1,5
          do lll=1,3
            derx(lll,kkk,iii)=0.0d0
          enddo
        enddo
      enddo
cd      eij=facont_hb(jj,i)
cd      ekl=facont_hb(kk,k)
cd      ekont=eij*ekl
cd      write (iout,*)'Contacts have occurred for peptide groups',
cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
cd      goto 1111
C Contribution from the graph I.
cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
      call transpose2(EUg(1,1,k),auxmat(1,1))
      call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
      vv(1)=pizda(1,1)-pizda(2,2)
      vv(2)=pizda(1,2)+pizda(2,1)
      eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
     & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
      if (calc_grad) then
C Explicit gradient in virtual-dihedral angles.
      if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
     & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
     & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
      call transpose2(EUgder(1,1,k),auxmat1(1,1))
      call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
      vv(1)=pizda(1,1)-pizda(2,2)
      vv(2)=pizda(1,2)+pizda(2,1)
      g_corr5_loc(k-1)=g_corr5_loc(k-1)
     & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
     & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
      call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
      vv(1)=pizda(1,1)-pizda(2,2)
      vv(2)=pizda(1,2)+pizda(2,1)
      if (l.eq.j+1) then
        if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
     &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
     &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
      else
        if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
     &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
     &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
      endif 
C Cartesian gradient
      do iii=1,2
        do kkk=1,5
          do lll=1,3
            call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
     &        pizda(1,1))
            vv(1)=pizda(1,1)-pizda(2,2)
            vv(2)=pizda(1,2)+pizda(2,1)
            derx(lll,kkk,iii)=derx(lll,kkk,iii)
     &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
     &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
          enddo
        enddo
      enddo
c      goto 1112
      endif
c1111  continue
C Contribution from graph II 
      call transpose2(EE(1,1,itk),auxmat(1,1))
      call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
      vv(1)=pizda(1,1)+pizda(2,2)
      vv(2)=pizda(2,1)-pizda(1,2)
      eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
     & -0.5d0*scalar2(vv(1),Ctobr(1,k))
      if (calc_grad) then
C Explicit gradient in virtual-dihedral angles.
      g_corr5_loc(k-1)=g_corr5_loc(k-1)
     & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
      call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
      vv(1)=pizda(1,1)+pizda(2,2)
      vv(2)=pizda(2,1)-pizda(1,2)
      if (l.eq.j+1) then
        g_corr5_loc(l-1)=g_corr5_loc(l-1)
     &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
     &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
      else
        g_corr5_loc(j-1)=g_corr5_loc(j-1)
     &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
     &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
      endif
C Cartesian gradient
      do iii=1,2
        do kkk=1,5
          do lll=1,3
            call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
     &        pizda(1,1))
            vv(1)=pizda(1,1)+pizda(2,2)
            vv(2)=pizda(2,1)-pizda(1,2)
            derx(lll,kkk,iii)=derx(lll,kkk,iii)
     &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
     &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
          enddo
        enddo
      enddo
cd      goto 1112
      endif
cd1111  continue
      if (l.eq.j+1) then
cd        goto 1110
C Parallel orientation
C Contribution from graph III
        call transpose2(EUg(1,1,l),auxmat(1,1))
        call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
        vv(1)=pizda(1,1)-pizda(2,2)
        vv(2)=pizda(1,2)+pizda(2,1)
        eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
     &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
        if (calc_grad) then
C Explicit gradient in virtual-dihedral angles.
        g_corr5_loc(j-1)=g_corr5_loc(j-1)
     &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
     &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
        call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
        vv(1)=pizda(1,1)-pizda(2,2)
        vv(2)=pizda(1,2)+pizda(2,1)
        g_corr5_loc(k-1)=g_corr5_loc(k-1)
     &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
     &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
        call transpose2(EUgder(1,1,l),auxmat1(1,1))
        call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
        vv(1)=pizda(1,1)-pizda(2,2)
        vv(2)=pizda(1,2)+pizda(2,1)
        g_corr5_loc(l-1)=g_corr5_loc(l-1)
     &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
     &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
C Cartesian gradient
        do iii=1,2
          do kkk=1,5
            do lll=1,3
              call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
     &          pizda(1,1))
              vv(1)=pizda(1,1)-pizda(2,2)
              vv(2)=pizda(1,2)+pizda(2,1)
              derx(lll,kkk,iii)=derx(lll,kkk,iii)
     &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
     &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
            enddo
          enddo
        enddo
cd        goto 1112
        endif
C Contribution from graph IV
cd1110    continue
        call transpose2(EE(1,1,itl),auxmat(1,1))
        call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
        vv(1)=pizda(1,1)+pizda(2,2)
        vv(2)=pizda(2,1)-pizda(1,2)
        eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
     &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
        if (calc_grad) then
C Explicit gradient in virtual-dihedral angles.
        g_corr5_loc(l-1)=g_corr5_loc(l-1)
     &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
        call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
        vv(1)=pizda(1,1)+pizda(2,2)
        vv(2)=pizda(2,1)-pizda(1,2)
        g_corr5_loc(k-1)=g_corr5_loc(k-1)
     &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
     &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
C Cartesian gradient
        do iii=1,2
          do kkk=1,5
            do lll=1,3
              call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
     &          pizda(1,1))
              vv(1)=pizda(1,1)+pizda(2,2)
              vv(2)=pizda(2,1)-pizda(1,2)
              derx(lll,kkk,iii)=derx(lll,kkk,iii)
     &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
     &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
            enddo
          enddo
        enddo
        endif
      else
C Antiparallel orientation
C Contribution from graph III
c        goto 1110
        call transpose2(EUg(1,1,j),auxmat(1,1))
        call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
        vv(1)=pizda(1,1)-pizda(2,2)
        vv(2)=pizda(1,2)+pizda(2,1)
        eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
     &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
        if (calc_grad) then
C Explicit gradient in virtual-dihedral angles.
        g_corr5_loc(l-1)=g_corr5_loc(l-1)
     &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
     &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
        call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
        vv(1)=pizda(1,1)-pizda(2,2)
        vv(2)=pizda(1,2)+pizda(2,1)
        g_corr5_loc(k-1)=g_corr5_loc(k-1)
     &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
     &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
        call transpose2(EUgder(1,1,j),auxmat1(1,1))
        call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
        vv(1)=pizda(1,1)-pizda(2,2)
        vv(2)=pizda(1,2)+pizda(2,1)
        g_corr5_loc(j-1)=g_corr5_loc(j-1)
     &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
     &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
C Cartesian gradient
        do iii=1,2
          do kkk=1,5
            do lll=1,3
              call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
     &          pizda(1,1))
              vv(1)=pizda(1,1)-pizda(2,2)
              vv(2)=pizda(1,2)+pizda(2,1)
              derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
     &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
     &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
            enddo
          enddo
        enddo
cd        goto 1112
        endif
C Contribution from graph IV
1110    continue
        call transpose2(EE(1,1,itj),auxmat(1,1))
        call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
        vv(1)=pizda(1,1)+pizda(2,2)
        vv(2)=pizda(2,1)-pizda(1,2)
        eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
     &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
        if (calc_grad) then
C Explicit gradient in virtual-dihedral angles.
        g_corr5_loc(j-1)=g_corr5_loc(j-1)
     &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
        call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
        vv(1)=pizda(1,1)+pizda(2,2)
        vv(2)=pizda(2,1)-pizda(1,2)
        g_corr5_loc(k-1)=g_corr5_loc(k-1)
     &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
     &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
C Cartesian gradient
        do iii=1,2
          do kkk=1,5
            do lll=1,3
              call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
     &          pizda(1,1))
              vv(1)=pizda(1,1)+pizda(2,2)
              vv(2)=pizda(2,1)-pizda(1,2)
              derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
     &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
     &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
            enddo
          enddo
        enddo
      endif
      endif
1112  continue
      eel5=eello5_1+eello5_2+eello5_3+eello5_4
cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
cd        write (2,*) 'ijkl',i,j,k,l
cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
cd      endif
cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
      if (calc_grad) then
      if (j.lt.nres-1) then
        j1=j+1
        j2=j-1
      else
        j1=j-1
        j2=j-2
      endif
      if (l.lt.nres-1) then
        l1=l+1
        l2=l-1
      else
        l1=l-1
        l2=l-2
      endif
cd      eij=1.0d0
cd      ekl=1.0d0
cd      ekont=1.0d0
cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
      do ll=1,3
        ggg1(ll)=eel5*g_contij(ll,1)
        ggg2(ll)=eel5*g_contij(ll,2)
cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
        ghalf=0.5d0*ggg1(ll)
cd        ghalf=0.0d0
        gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
        gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
        gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
        gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
        ghalf=0.5d0*ggg2(ll)
cd        ghalf=0.0d0
        gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
        gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
        gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
        gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
      enddo
cd      goto 1112
      do m=i+1,j-1
        do ll=1,3
cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
        enddo
      enddo
      do m=k+1,l-1
        do ll=1,3
cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
        enddo
      enddo
c1112  continue
      do m=i+2,j2
        do ll=1,3
          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
        enddo
      enddo
      do m=k+2,l2
        do ll=1,3
          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
        enddo
      enddo 
cd      do iii=1,nres-3
cd        write (2,*) iii,g_corr5_loc(iii)
cd      enddo
      endif
      eello5=ekont*eel5
cd      write (2,*) 'ekont',ekont
cd      write (iout,*) 'eello5',ekont*eel5
      return
      end
c--------------------------------------------------------------------------
      double precision function eello6(i,j,k,l,jj,kk)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.TORSION'
      include 'COMMON.VAR'
      include 'COMMON.GEO'
      include 'COMMON.FFIELD'
      double precision ggg1(3),ggg2(3)
cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
cd        eello6=0.0d0
cd        return
cd      endif
cd      write (iout,*)
cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
cd     &   ' and',k,l
      eello6_1=0.0d0
      eello6_2=0.0d0
      eello6_3=0.0d0
      eello6_4=0.0d0
      eello6_5=0.0d0
      eello6_6=0.0d0
cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
      do iii=1,2
        do kkk=1,5
          do lll=1,3
            derx(lll,kkk,iii)=0.0d0
          enddo
        enddo
      enddo
cd      eij=facont_hb(jj,i)
cd      ekl=facont_hb(kk,k)
cd      ekont=eij*ekl
cd      eij=1.0d0
cd      ekl=1.0d0
cd      ekont=1.0d0
      if (l.eq.j+1) then
        eello6_1=eello6_graph1(i,j,k,l,1,.false.)
        eello6_2=eello6_graph1(j,i,l,k,2,.false.)
        eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
        eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
        eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
        eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
      else
        eello6_1=eello6_graph1(i,j,k,l,1,.false.)
        eello6_2=eello6_graph1(l,k,j,i,2,.true.)
        eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
        eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
        if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
          eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
        else
          eello6_5=0.0d0
        endif
        eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
      endif
C If turn contributions are considered, they will be handled separately.
      eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
cd      goto 1112
      if (calc_grad) then
      if (j.lt.nres-1) then
        j1=j+1
        j2=j-1
      else
        j1=j-1
        j2=j-2
      endif
      if (l.lt.nres-1) then
        l1=l+1
        l2=l-1
      else
        l1=l-1
        l2=l-2
      endif
      do ll=1,3
        ggg1(ll)=eel6*g_contij(ll,1)
        ggg2(ll)=eel6*g_contij(ll,2)
cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
        ghalf=0.5d0*ggg1(ll)
cd        ghalf=0.0d0
        gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
        gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
        gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
        gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
        ghalf=0.5d0*ggg2(ll)
cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
cd        ghalf=0.0d0
        gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
        gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
        gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
        gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
      enddo
cd      goto 1112
      do m=i+1,j-1
        do ll=1,3
cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
        enddo
      enddo
      do m=k+1,l-1
        do ll=1,3
cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
        enddo
      enddo
1112  continue
      do m=i+2,j2
        do ll=1,3
          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
        enddo
      enddo
      do m=k+2,l2
        do ll=1,3
          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
        enddo
      enddo 
cd      do iii=1,nres-3
cd        write (2,*) iii,g_corr6_loc(iii)
cd      enddo
      endif
      eello6=ekont*eel6
cd      write (2,*) 'ekont',ekont
cd      write (iout,*) 'eello6',ekont*eel6
      return
      end
c--------------------------------------------------------------------------
      double precision function eello6_graph1(i,j,k,l,imat,swap)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.TORSION'
      include 'COMMON.VAR'
      include 'COMMON.GEO'
      double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
      logical swap
      logical lprn
      common /kutas/ lprn
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                              C 
C      Parallel       Antiparallel                                             C
C                                                                              C
C          o             o                                                     C
C         /l\           /j\                                                    C
C        /   \         /   \                                                   C
C       /| o |         | o |\                                                  C
C     \ j|/k\|  /   \  |/k\|l /                                                C
C      \ /   \ /     \ /   \ /                                                 C
C       o     o       o     o                                                  C
C       i             i                                                        C
C                                                                              C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      itk=itortyp(itype(k))
      s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
      s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
      s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
      call transpose2(EUgC(1,1,k),auxmat(1,1))
      call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
      vv1(1)=pizda1(1,1)-pizda1(2,2)
      vv1(2)=pizda1(1,2)+pizda1(2,1)
      s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
      vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
      vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
      s5=scalar2(vv(1),Dtobr2(1,i))
cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
      eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
      if (.not. calc_grad) return
      if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
     & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
     & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
     & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
     & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
     & +scalar2(vv(1),Dtobr2der(1,i)))
      call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
      vv1(1)=pizda1(1,1)-pizda1(2,2)
      vv1(2)=pizda1(1,2)+pizda1(2,1)
      vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
      vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
      if (l.eq.j+1) then
        g_corr6_loc(l-1)=g_corr6_loc(l-1)
     & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
     & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
     & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
     & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
      else
        g_corr6_loc(j-1)=g_corr6_loc(j-1)
     & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
     & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
     & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
     & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
      endif
      call transpose2(EUgCder(1,1,k),auxmat(1,1))
      call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
      vv1(1)=pizda1(1,1)-pizda1(2,2)
      vv1(2)=pizda1(1,2)+pizda1(2,1)
      if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
     & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
     & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
     & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
      do iii=1,2
        if (swap) then
          ind=3-iii
        else
          ind=iii
        endif
        do kkk=1,5
          do lll=1,3
            s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
            s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
            s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
            call transpose2(EUgC(1,1,k),auxmat(1,1))
            call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
     &        pizda1(1,1))
            vv1(1)=pizda1(1,1)-pizda1(2,2)
            vv1(2)=pizda1(1,2)+pizda1(2,1)
            s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
            vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
     &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
            vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
     &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
            s5=scalar2(vv(1),Dtobr2(1,i))
            derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
          enddo
        enddo
      enddo
      return
      end
c----------------------------------------------------------------------------
      double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.TORSION'
      include 'COMMON.VAR'
      include 'COMMON.GEO'
      logical swap
      double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
     & auxvec1(2),auxvec2(2),auxmat1(2,2)
      logical lprn
      common /kutas/ lprn
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                              C 
C      Parallel       Antiparallel                                             C
C                                                                              C
C          o             o                                                     C
C     \   /l\           /j\   /                                                C
C      \ /   \         /   \ /                                                 C
C       o| o |         | o |o                                                  C
C     \ j|/k\|      \  |/k\|l                                                  C
C      \ /   \       \ /   \                                                   C
C       o             o                                                        C
C       i             i                                                        C
C                                                                              C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
C AL 7/4/01 s1 would occur in the sixth-order moment, 
C           but not in a cluster cumulant
#ifdef MOMENT
      s1=dip(1,jj,i)*dip(1,kk,k)
#endif
      call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
      s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
      call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
      s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
      call transpose2(EUg(1,1,k),auxmat(1,1))
      call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
      vv(1)=pizda(1,1)-pizda(2,2)
      vv(2)=pizda(1,2)+pizda(2,1)
      s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
#ifdef MOMENT
      eello6_graph2=-(s1+s2+s3+s4)
#else
      eello6_graph2=-(s2+s3+s4)
#endif
c      eello6_graph2=-s3
      if (.not. calc_grad) return
C Derivatives in gamma(i-1)
      if (i.gt.1) then
#ifdef MOMENT
        s1=dipderg(1,jj,i)*dip(1,kk,k)
#endif
        s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
        call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
        s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
        s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
#ifdef MOMENT
        g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
#else
        g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
#endif
c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
      endif
C Derivatives in gamma(k-1)
#ifdef MOMENT
      s1=dip(1,jj,i)*dipderg(1,kk,k)
#endif
      call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
      s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
      call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
      s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
      call transpose2(EUgder(1,1,k),auxmat1(1,1))
      call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
      vv(1)=pizda(1,1)-pizda(2,2)
      vv(2)=pizda(1,2)+pizda(2,1)
      s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
#ifdef MOMENT
      g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
#else
      g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
#endif
c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
C Derivatives in gamma(j-1) or gamma(l-1)
      if (j.gt.1) then
#ifdef MOMENT
        s1=dipderg(3,jj,i)*dip(1,kk,k) 
#endif
        call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
        s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
        s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
        call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
        vv(1)=pizda(1,1)-pizda(2,2)
        vv(2)=pizda(1,2)+pizda(2,1)
        s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
#ifdef MOMENT
        if (swap) then
          g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
        else
          g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
        endif
#endif
        g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
      endif
C Derivatives in gamma(l-1) or gamma(j-1)
      if (l.gt.1) then 
#ifdef MOMENT
        s1=dip(1,jj,i)*dipderg(3,kk,k)
#endif
        call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
        s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
        call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
        s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
        call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
        vv(1)=pizda(1,1)-pizda(2,2)
        vv(2)=pizda(1,2)+pizda(2,1)
        s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
#ifdef MOMENT
        if (swap) then
          g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
        else
          g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
        endif
#endif
        g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
      endif
C Cartesian derivatives.
      if (lprn) then
        write (2,*) 'In eello6_graph2'
        do iii=1,2
          write (2,*) 'iii=',iii
          do kkk=1,5
            write (2,*) 'kkk=',kkk
            do jjj=1,2
              write (2,'(3(2f10.5),5x)') 
     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
            enddo
          enddo
        enddo
      endif
      do iii=1,2
        do kkk=1,5
          do lll=1,3
#ifdef MOMENT
            if (iii.eq.1) then
              s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
            else
              s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
            endif
#endif
            call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
     &        auxvec(1))
            s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
            call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
     &        auxvec(1))
            s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
            call transpose2(EUg(1,1,k),auxmat(1,1))
            call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
     &        pizda(1,1))
            vv(1)=pizda(1,1)-pizda(2,2)
            vv(2)=pizda(1,2)+pizda(2,1)
            s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
#ifdef MOMENT
            derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
#else
            derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
#endif
            if (swap) then
              derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
            else
              derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
            endif
          enddo
        enddo
      enddo
      return
      end
c----------------------------------------------------------------------------
      double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.TORSION'
      include 'COMMON.VAR'
      include 'COMMON.GEO'
      double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
      logical swap
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                              C
C      Parallel       Antiparallel                                             C
C                                                                              C
C          o             o                                                     C
C         /l\   /   \   /j\                                                    C
C        /   \ /     \ /   \                                                   C
C       /| o |o       o| o |\                                                  C
C       j|/k\|  /      |/k\|l /                                                C
C        /   \ /       /   \ /                                                 C
C       /     o       /     o                                                  C
C       i             i                                                        C
C                                                                              C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C 4/7/01 AL Component s1 was removed, because it pertains to the respective 
C           energy moment and not to the cluster cumulant.
      iti=itortyp(itype(i))
c      if (j.lt.nres-1) then
      if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
        itj1=itortyp(itype(j+1))
      else
        itj1=ntortyp+1
      endif
      itk=itortyp(itype(k))
      itk1=itortyp(itype(k+1))
c      if (l.lt.nres-1) then
      if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
        itl1=itortyp(itype(l+1))
      else
        itl1=ntortyp+1
      endif
#ifdef MOMENT
      s1=dip(4,jj,i)*dip(4,kk,k)
#endif
      call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
      s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
      call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
      s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
      call transpose2(EE(1,1,itk),auxmat(1,1))
      call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
      vv(1)=pizda(1,1)+pizda(2,2)
      vv(2)=pizda(2,1)-pizda(1,2)
      s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
#ifdef MOMENT
      eello6_graph3=-(s1+s2+s3+s4)
#else
      eello6_graph3=-(s2+s3+s4)
#endif
c      eello6_graph3=-s4
      if (.not. calc_grad) return
C Derivatives in gamma(k-1)
      call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
      s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
      s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
      g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
C Derivatives in gamma(l-1)
      call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
      s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
      call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
      vv(1)=pizda(1,1)+pizda(2,2)
      vv(2)=pizda(2,1)-pizda(1,2)
      s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
      g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) 
C Cartesian derivatives.
      do iii=1,2
        do kkk=1,5
          do lll=1,3
#ifdef MOMENT
            if (iii.eq.1) then
              s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
            else
              s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
            endif
#endif
            call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
     &        auxvec(1))
            s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
            call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
     &        auxvec(1))
            s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
            call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
     &        pizda(1,1))
            vv(1)=pizda(1,1)+pizda(2,2)
            vv(2)=pizda(2,1)-pizda(1,2)
            s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
#ifdef MOMENT
            derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
#else
            derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
#endif
            if (swap) then
              derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
            else
              derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
            endif
c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
          enddo
        enddo
      enddo
      return
      end
c----------------------------------------------------------------------------
      double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.TORSION'
      include 'COMMON.VAR'
      include 'COMMON.GEO'
      include 'COMMON.FFIELD'
      double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
     & auxvec1(2),auxmat1(2,2)
      logical swap
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                              C
C      Parallel       Antiparallel                                             C
C                                                                              C
C          o             o                                                     C
C         /l\   /   \   /j\                                                    C
C        /   \ /     \ /   \                                                   C
C       /| o |o       o| o |\                                                  C
C     \ j|/k\|      \  |/k\|l                                                  C
C      \ /   \       \ /   \                                                   C
C       o     \       o     \                                                  C
C       i             i                                                        C
C                                                                              C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C 4/7/01 AL Component s1 was removed, because it pertains to the respective 
C           energy moment and not to the cluster cumulant.
cd      write (2,*) 'eello_graph4: wturn6',wturn6
      iti=itortyp(itype(i))
      itj=itortyp(itype(j))
c      if (j.lt.nres-1) then
      if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
        itj1=itortyp(itype(j+1))
      else
        itj1=ntortyp+1
      endif
      itk=itortyp(itype(k))
c      if (k.lt.nres-1) then
      if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
        itk1=itortyp(itype(k+1))
      else
        itk1=ntortyp+1
      endif
      itl=itortyp(itype(l))
      if (l.lt.nres-1) then
        itl1=itortyp(itype(l+1))
      else
        itl1=ntortyp+1
      endif
cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
cd     & ' itl',itl,' itl1',itl1
#ifdef MOMENT
      if (imat.eq.1) then
        s1=dip(3,jj,i)*dip(3,kk,k)
      else
        s1=dip(2,jj,j)*dip(2,kk,l)
      endif
#endif
      call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
      s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
      if (j.eq.l+1) then
        call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
        s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
      else
        call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
        s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
      endif
      call transpose2(EUg(1,1,k),auxmat(1,1))
      call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
      vv(1)=pizda(1,1)-pizda(2,2)
      vv(2)=pizda(2,1)+pizda(1,2)
      s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
#ifdef MOMENT
      eello6_graph4=-(s1+s2+s3+s4)
#else
      eello6_graph4=-(s2+s3+s4)
#endif
      if (.not. calc_grad) return
C Derivatives in gamma(i-1)
      if (i.gt.1) then
#ifdef MOMENT
        if (imat.eq.1) then
          s1=dipderg(2,jj,i)*dip(3,kk,k)
        else
          s1=dipderg(4,jj,j)*dip(2,kk,l)
        endif
#endif
        s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
        if (j.eq.l+1) then
          call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
          s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
        else
          call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
          s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
        endif
        s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
        if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
cd          write (2,*) 'turn6 derivatives'
#ifdef MOMENT
          gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
#else
          gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
#endif
        else
#ifdef MOMENT
          g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
#else
          g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
#endif
        endif
      endif
C Derivatives in gamma(k-1)
#ifdef MOMENT
      if (imat.eq.1) then
        s1=dip(3,jj,i)*dipderg(2,kk,k)
      else
        s1=dip(2,jj,j)*dipderg(4,kk,l)
      endif
#endif
      call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
      s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
      if (j.eq.l+1) then
        call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
        s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
      else
        call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
        s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
      endif
      call transpose2(EUgder(1,1,k),auxmat1(1,1))
      call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
      vv(1)=pizda(1,1)-pizda(2,2)
      vv(2)=pizda(2,1)+pizda(1,2)
      s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
      if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
#ifdef MOMENT
        gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
#else
        gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
#endif
      else
#ifdef MOMENT
        g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
#else
        g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
#endif
      endif
C Derivatives in gamma(j-1) or gamma(l-1)
      if (l.eq.j+1 .and. l.gt.1) then
        call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
        s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
        call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
        vv(1)=pizda(1,1)-pizda(2,2)
        vv(2)=pizda(2,1)+pizda(1,2)
        s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
        g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
      else if (j.gt.1) then
        call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
        s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
        call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
        vv(1)=pizda(1,1)-pizda(2,2)
        vv(2)=pizda(2,1)+pizda(1,2)
        s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
        if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
          gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
        else
          g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
        endif
      endif
C Cartesian derivatives.
      do iii=1,2
        do kkk=1,5
          do lll=1,3
#ifdef MOMENT
            if (iii.eq.1) then
              if (imat.eq.1) then
                s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
              else
                s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
              endif
            else
              if (imat.eq.1) then
                s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
              else
                s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
              endif
            endif
#endif
            call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
     &        auxvec(1))
            s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
            if (j.eq.l+1) then
              call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
     &          b1(1,itj1),auxvec(1))
              s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
            else
              call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
     &          b1(1,itl1),auxvec(1))
              s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
            endif
            call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
     &        pizda(1,1))
            vv(1)=pizda(1,1)-pizda(2,2)
            vv(2)=pizda(2,1)+pizda(1,2)
            s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
            if (swap) then
              if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
#ifdef MOMENT
                derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
     &             -(s1+s2+s4)
#else
                derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
     &             -(s2+s4)
#endif
                derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
              else
#ifdef MOMENT
                derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
#else
                derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
#endif
                derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
              endif
            else
#ifdef MOMENT
              derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
#else
              derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
#endif
              if (l.eq.j+1) then
                derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
              else 
                derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
              endif
            endif 
          enddo
        enddo
      enddo
      return
      end
c----------------------------------------------------------------------------
      double precision function eello_turn6(i,jj,kk)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'sizesclu.dat'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.TORSION'
      include 'COMMON.VAR'
      include 'COMMON.GEO'
      double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
     &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
     &  ggg1(3),ggg2(3)
      double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
     &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
C           the respective energy moment and not to the cluster cumulant.
      eello_turn6=0.0d0
      j=i+4
      k=i+1
      l=i+3
      iti=itortyp(itype(i))
      itk=itortyp(itype(k))
      itk1=itortyp(itype(k+1))
      itl=itortyp(itype(l))
      itj=itortyp(itype(j))
cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
cd        eello6=0.0d0
cd        return
cd      endif
cd      write (iout,*)
cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
cd     &   ' and',k,l
cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
      do iii=1,2
        do kkk=1,5
          do lll=1,3
            derx_turn(lll,kkk,iii)=0.0d0
          enddo
        enddo
      enddo
cd      eij=1.0d0
cd      ekl=1.0d0
cd      ekont=1.0d0
      eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
cd      eello6_5=0.0d0
cd      write (2,*) 'eello6_5',eello6_5
#ifdef MOMENT
      call transpose2(AEA(1,1,1),auxmat(1,1))
      call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
      ss1=scalar2(Ub2(1,i+2),b1(1,itl))
      s1 = (auxmat(1,1)+auxmat(2,2))*ss1
#else
      s1 = 0.0d0
#endif
      call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
      call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
      s2 = scalar2(b1(1,itk),vtemp1(1))
#ifdef MOMENT
      call transpose2(AEA(1,1,2),atemp(1,1))
      call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
      call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
      s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
#else
      s8=0.0d0
#endif
      call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
      call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
      s12 = scalar2(Ub2(1,i+2),vtemp3(1))
#ifdef MOMENT
      call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
      call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
      call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) 
      call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) 
      ss13 = scalar2(b1(1,itk),vtemp4(1))
      s13 = (gtemp(1,1)+gtemp(2,2))*ss13
#else
      s13=0.0d0
#endif
c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
c      s1=0.0d0
c      s2=0.0d0
c      s8=0.0d0
c      s12=0.0d0
c      s13=0.0d0
      eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
      if (calc_grad) then
C Derivatives in gamma(i+2)
#ifdef MOMENT
      call transpose2(AEA(1,1,1),auxmatd(1,1))
      call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
      s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
      call transpose2(AEAderg(1,1,2),atempd(1,1))
      call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
      s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
#else
      s8d=0.0d0
#endif
      call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
      call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
      s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
c      s1d=0.0d0
c      s2d=0.0d0
c      s8d=0.0d0
c      s12d=0.0d0
c      s13d=0.0d0
      gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
C Derivatives in gamma(i+3)
#ifdef MOMENT
      call transpose2(AEA(1,1,1),auxmatd(1,1))
      call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
      ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
      s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
#else
      s1d=0.0d0
#endif
      call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
      call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
      s2d = scalar2(b1(1,itk),vtemp1d(1))
#ifdef MOMENT
      call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
      s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
#endif
      s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
#ifdef MOMENT
      call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
      call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) 
      s13d = (gtempd(1,1)+gtempd(2,2))*ss13
#else
      s13d=0.0d0
#endif
c      s1d=0.0d0
c      s2d=0.0d0
c      s8d=0.0d0
c      s12d=0.0d0
c      s13d=0.0d0
#ifdef MOMENT
      gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
     &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
#else
      gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
     &               -0.5d0*ekont*(s2d+s12d)
#endif
C Derivatives in gamma(i+4)
      call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
      call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
      s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
#ifdef MOMENT
      call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
      call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) 
      s13d = (gtempd(1,1)+gtempd(2,2))*ss13
#else
      s13d = 0.0d0
#endif
c      s1d=0.0d0
c      s2d=0.0d0
c      s8d=0.0d0
C      s12d=0.0d0
c      s13d=0.0d0
#ifdef MOMENT
      gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
#else
      gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
#endif
C Derivatives in gamma(i+5)
#ifdef MOMENT
      call transpose2(AEAderg(1,1,1),auxmatd(1,1))
      call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
      s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
#else
      s1d = 0.0d0
#endif
      call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
      call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
      s2d = scalar2(b1(1,itk),vtemp1d(1))
#ifdef MOMENT
      call transpose2(AEA(1,1,2),atempd(1,1))
      call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
      s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
#else
      s8d = 0.0d0
#endif
      call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
      s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
#ifdef MOMENT
      call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) 
      ss13d = scalar2(b1(1,itk),vtemp4d(1))
      s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
#else
      s13d = 0.0d0
#endif
c      s1d=0.0d0
c      s2d=0.0d0
c      s8d=0.0d0
c      s12d=0.0d0
c      s13d=0.0d0
#ifdef MOMENT
      gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
     &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
#else
      gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
     &               -0.5d0*ekont*(s2d+s12d)
#endif
C Cartesian derivatives
      do iii=1,2
        do kkk=1,5
          do lll=1,3
#ifdef MOMENT
            call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
            call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
            s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
#else
            s1d = 0.0d0
#endif
            call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
            call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
     &          vtemp1d(1))
            s2d = scalar2(b1(1,itk),vtemp1d(1))
#ifdef MOMENT
            call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
            call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
            s8d = -(atempd(1,1)+atempd(2,2))*
     &           scalar2(cc(1,1,itl),vtemp2(1))
#else
            s8d = 0.0d0
#endif
            call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
     &           auxmatd(1,1))
            call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
            s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
c      s1d=0.0d0
c      s2d=0.0d0
c      s8d=0.0d0
c      s12d=0.0d0
c      s13d=0.0d0
#ifdef MOMENT
            derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) 
     &        - 0.5d0*(s1d+s2d)
#else
            derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) 
     &        - 0.5d0*s2d
#endif
#ifdef MOMENT
            derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) 
     &        - 0.5d0*(s8d+s12d)
#else
            derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) 
     &        - 0.5d0*s12d
#endif
          enddo
        enddo
      enddo
#ifdef MOMENT
      do kkk=1,5
        do lll=1,3
          call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
     &      achuj_tempd(1,1))
          call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
          call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) 
          s13d=(gtempd(1,1)+gtempd(2,2))*ss13
          derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
          call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
     &      vtemp4d(1)) 
          ss13d = scalar2(b1(1,itk),vtemp4d(1))
          s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
          derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
        enddo
      enddo
#endif
cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
cd     &  16*eel_turn6_num
cd      goto 1112
      if (j.lt.nres-1) then
        j1=j+1
        j2=j-1
      else
        j1=j-1
        j2=j-2
      endif
      if (l.lt.nres-1) then
        l1=l+1
        l2=l-1
      else
        l1=l-1
        l2=l-2
      endif
      do ll=1,3
        ggg1(ll)=eel_turn6*g_contij(ll,1)
        ggg2(ll)=eel_turn6*g_contij(ll,2)
        ghalf=0.5d0*ggg1(ll)
cd        ghalf=0.0d0
        gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
     &    +ekont*derx_turn(ll,2,1)
        gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
        gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
     &    +ekont*derx_turn(ll,4,1)
        gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
        ghalf=0.5d0*ggg2(ll)
cd        ghalf=0.0d0
        gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
     &    +ekont*derx_turn(ll,2,2)
        gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
        gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
     &    +ekont*derx_turn(ll,4,2)
        gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
      enddo
cd      goto 1112
      do m=i+1,j-1
        do ll=1,3
          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
        enddo
      enddo
      do m=k+1,l-1
        do ll=1,3
          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
        enddo
      enddo
1112  continue
      do m=i+2,j2
        do ll=1,3
          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
        enddo
      enddo
      do m=k+2,l2
        do ll=1,3
          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
        enddo
      enddo 
cd      do iii=1,nres-3
cd        write (2,*) iii,g_corr6_loc(iii)
cd      enddo
      endif
      eello_turn6=ekont*eel_turn6
cd      write (2,*) 'ekont',ekont
cd      write (2,*) 'eel_turn6',ekont*eel_turn6
      return
      end
crc-------------------------------------------------
      SUBROUTINE MATVEC2(A1,V1,V2)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      DIMENSION A1(2,2),V1(2),V2(2)
c      DO 1 I=1,2
c        VI=0.0
c        DO 3 K=1,2
c    3     VI=VI+A1(I,K)*V1(K)
c        Vaux(I)=VI
c    1 CONTINUE

      vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
      vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)

      v2(1)=vaux1
      v2(2)=vaux2
      END
C---------------------------------------
      SUBROUTINE MATMAT2(A1,A2,A3)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      DIMENSION A1(2,2),A2(2,2),A3(2,2)
c      DIMENSION AI3(2,2)
c        DO  J=1,2
c          A3IJ=0.0
c          DO K=1,2
c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
c          enddo
c          A3(I,J)=A3IJ
c       enddo
c      enddo

      ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
      ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
      ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
      ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)

      A3(1,1)=AI3_11
      A3(2,1)=AI3_21
      A3(1,2)=AI3_12
      A3(2,2)=AI3_22
      END

c-------------------------------------------------------------------------
      double precision function scalar2(u,v)
      implicit none
      double precision u(2),v(2)
      double precision sc
      integer i
      scalar2=u(1)*v(1)+u(2)*v(2)
      return
      end

C-----------------------------------------------------------------------------

      subroutine transpose2(a,at)
      implicit none
      double precision a(2,2),at(2,2)
      at(1,1)=a(1,1)
      at(1,2)=a(2,1)
      at(2,1)=a(1,2)
      at(2,2)=a(2,2)
      return
      end
c--------------------------------------------------------------------------
      subroutine transpose(n,a,at)
      implicit none
      integer n,i,j
      double precision a(n,n),at(n,n)
      do i=1,n
        do j=1,n
          at(j,i)=a(i,j)
        enddo
      enddo
      return
      end
C---------------------------------------------------------------------------
      subroutine prodmat3(a1,a2,kk,transp,prod)
      implicit none
      integer i,j
      double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
      logical transp
crc      double precision auxmat(2,2),prod_(2,2)

      if (transp) then
crc        call transpose2(kk(1,1),auxmat(1,1))
crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) 
        
           prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
     & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
           prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
     & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
           prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
     & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
           prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
     & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)

      else
crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))

           prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
     &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
           prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
     &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
           prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
     &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
           prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
     &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)

      endif
c      call transpose2(a2(1,1),a2t(1,1))

crc      print *,transp
crc      print *,((prod_(i,j),i=1,2),j=1,2)
crc      print *,((prod(i,j),i=1,2),j=1,2)

      return
      end
C-----------------------------------------------------------------------------
      double precision function scalar(u,v)
      implicit none
      double precision u(3),v(3)
      double precision sc
      integer i
      sc=0.0d0
      do i=1,3
        sc=sc+u(i)*v(i)
      enddo
      scalar=sc
      return
      end
C-----------------------------------------------------------------------
      double precision function sscale(r)
      double precision r,gamm
      include "COMMON.SPLITELE"
      if(r.lt.r_cut-rlamb) then
        sscale=1.0d0
      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
        gamm=(r-(r_cut-rlamb))/rlamb
        sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
      else
        sscale=0d0
      endif
      return
      end
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
      double precision function sscagrad(r)
      double precision r,gamm
      include "COMMON.SPLITELE"
      if(r.lt.r_cut-rlamb) then
        sscagrad=0.0d0
      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
        gamm=(r-(r_cut-rlamb))/rlamb
        sscagrad=gamm*(6*gamm-6.0d0)/rlamb
      else
        sscagrad=0.0d0
      endif
      return
      end
C-----------------------------------------------------------------------
C first for shielding is setting of function of side-chains
       subroutine set_shield_fac2
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.IOUNITS'
      include 'COMMON.SHIELD'
      include 'COMMON.INTERACT'
C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
      double precision div77_81/0.974996043d0/,
     &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)

C the vector between center of side_chain and peptide group
       double precision pep_side(3),long,side_calf(3),
     &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
     &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
C the line belowe needs to be changed for FGPROC>1
      do i=1,nres-1
      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
      ishield_list(i)=0
Cif there two consequtive dummy atoms there is no peptide group between them
C the line below has to be changed for FGPROC>1
      VolumeTotal=0.0
      do k=1,nres
       if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
       dist_pep_side=0.0
       dist_side_calf=0.0
       do j=1,3
C first lets set vector conecting the ithe side-chain with kth side-chain
      pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
C      pep_side(j)=2.0d0
C and vector conecting the side-chain with its proper calfa
      side_calf(j)=c(j,k+nres)-c(j,k)
C      side_calf(j)=2.0d0
      pept_group(j)=c(j,i)-c(j,i+1)
C lets have their lenght
      dist_pep_side=pep_side(j)**2+dist_pep_side
      dist_side_calf=dist_side_calf+side_calf(j)**2
      dist_pept_group=dist_pept_group+pept_group(j)**2
      enddo
       dist_pep_side=dsqrt(dist_pep_side)
       dist_pept_group=dsqrt(dist_pept_group)
       dist_side_calf=dsqrt(dist_side_calf)
      do j=1,3
        pep_side_norm(j)=pep_side(j)/dist_pep_side
        side_calf_norm(j)=dist_side_calf
      enddo
C now sscale fraction
       sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
C       print *,buff_shield,"buff"
C now sscale
        if (sh_frac_dist.le.0.0) cycle
C If we reach here it means that this side chain reaches the shielding sphere
C Lets add him to the list for gradient       
        ishield_list(i)=ishield_list(i)+1
C ishield_list is a list of non 0 side-chain that contribute to factor gradient
C this list is essential otherwise problem would be O3
        shield_list(ishield_list(i),i)=k
C Lets have the sscale value
        if (sh_frac_dist.gt.1.0) then
         scale_fac_dist=1.0d0
         do j=1,3
         sh_frac_dist_grad(j)=0.0d0
         enddo
        else
         scale_fac_dist=-sh_frac_dist*sh_frac_dist
     &                   *(2.0d0*sh_frac_dist-3.0d0)
         fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
     &                  /dist_pep_side/buff_shield*0.5d0
C remember for the final gradient multiply sh_frac_dist_grad(j) 
C for side_chain by factor -2 ! 
         do j=1,3
         sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
C         sh_frac_dist_grad(j)=0.0d0
C         scale_fac_dist=1.0d0
C         print *,"jestem",scale_fac_dist,fac_help_scale,
C     &                    sh_frac_dist_grad(j)
         enddo
        endif
C this is what is now we have the distance scaling now volume...
      short=short_r_sidechain(itype(k))
      long=long_r_sidechain(itype(k))
      costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
      sinthet=short/dist_pep_side*costhet
C now costhet_grad
C       costhet=0.6d0
C       sinthet=0.8
       costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
C     &             -short/dist_pep_side**2/costhet)
C       costhet_fac=0.0d0
       do j=1,3
         costhet_grad(j)=costhet_fac*pep_side(j)
       enddo
C remember for the final gradient multiply costhet_grad(j) 
C for side_chain by factor -2 !
C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
C pep_side0pept_group is vector multiplication  
      pep_side0pept_group=0.0d0
      do j=1,3
      pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
      enddo
      cosalfa=(pep_side0pept_group/
     & (dist_pep_side*dist_side_calf))
      fac_alfa_sin=1.0d0-cosalfa**2
      fac_alfa_sin=dsqrt(fac_alfa_sin)
      rkprim=fac_alfa_sin*(long-short)+short
C      rkprim=short

C now costhet_grad
       cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
C       cosphi=0.6
       cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
       sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
     &      dist_pep_side**2)
C       sinphi=0.8
       do j=1,3
         cosphi_grad_long(j)=cosphi_fac*pep_side(j)
     &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
     &*(long-short)/fac_alfa_sin*cosalfa/
     &((dist_pep_side*dist_side_calf))*
     &((side_calf(j))-cosalfa*
     &((pep_side(j)/dist_pep_side)*dist_side_calf))
C       cosphi_grad_long(j)=0.0d0
        cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
     &*(long-short)/fac_alfa_sin*cosalfa
     &/((dist_pep_side*dist_side_calf))*
     &(pep_side(j)-
     &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
C       cosphi_grad_loc(j)=0.0d0
       enddo
C      print *,sinphi,sinthet
      VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
     &                    /VSolvSphere_div
C     &                    *wshield
C now the gradient...
      do j=1,3
      grad_shield(j,i)=grad_shield(j,i)
C gradient po skalowaniu
     &                +(sh_frac_dist_grad(j)*VofOverlap
C  gradient po costhet
     &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
     &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
     &       sinphi/sinthet*costhet*costhet_grad(j)
     &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
     & )*wshield
C grad_shield_side is Cbeta sidechain gradient
      grad_shield_side(j,ishield_list(i),i)=
     &        (sh_frac_dist_grad(j)*-2.0d0
     &        *VofOverlap
     &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
     &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
     &       sinphi/sinthet*costhet*costhet_grad(j)
     &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
     &       )*wshield

       grad_shield_loc(j,ishield_list(i),i)=
     &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
     &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
     &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
     &        ))
     &        *wshield
      enddo
      VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
      enddo
      fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
      enddo
      return
      end
C first for shielding is setting of function of side-chains
       subroutine set_shield_fac
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.IOUNITS'
      include 'COMMON.SHIELD'
      include 'COMMON.INTERACT'
C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
      double precision div77_81/0.974996043d0/,
     &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)

C the vector between center of side_chain and peptide group
       double precision pep_side(3),long,side_calf(3),
     &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
     &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
C the line belowe needs to be changed for FGPROC>1
      do i=1,nres-1
      if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
      ishield_list(i)=0
Cif there two consequtive dummy atoms there is no peptide group between them
C the line below has to be changed for FGPROC>1
      VolumeTotal=0.0
      do k=1,nres
       if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
       dist_pep_side=0.0
       dist_side_calf=0.0
       do j=1,3
C first lets set vector conecting the ithe side-chain with kth side-chain
      pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
C      pep_side(j)=2.0d0
C and vector conecting the side-chain with its proper calfa
      side_calf(j)=c(j,k+nres)-c(j,k)
C      side_calf(j)=2.0d0
      pept_group(j)=c(j,i)-c(j,i+1)
C lets have their lenght
      dist_pep_side=pep_side(j)**2+dist_pep_side
      dist_side_calf=dist_side_calf+side_calf(j)**2
      dist_pept_group=dist_pept_group+pept_group(j)**2
      enddo
       dist_pep_side=dsqrt(dist_pep_side)
       dist_pept_group=dsqrt(dist_pept_group)
       dist_side_calf=dsqrt(dist_side_calf)
      do j=1,3
        pep_side_norm(j)=pep_side(j)/dist_pep_side
        side_calf_norm(j)=dist_side_calf
      enddo
C now sscale fraction
       sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
C       print *,buff_shield,"buff"
C now sscale
        if (sh_frac_dist.le.0.0) cycle
C If we reach here it means that this side chain reaches the shielding sphere
C Lets add him to the list for gradient       
        ishield_list(i)=ishield_list(i)+1
C ishield_list is a list of non 0 side-chain that contribute to factor gradient
C this list is essential otherwise problem would be O3
        shield_list(ishield_list(i),i)=k
C Lets have the sscale value
        if (sh_frac_dist.gt.1.0) then
         scale_fac_dist=1.0d0
         do j=1,3
         sh_frac_dist_grad(j)=0.0d0
         enddo
        else
         scale_fac_dist=-sh_frac_dist*sh_frac_dist
     &                   *(2.0*sh_frac_dist-3.0d0)
         fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
     &                  /dist_pep_side/buff_shield*0.5
C remember for the final gradient multiply sh_frac_dist_grad(j) 
C for side_chain by factor -2 ! 
         do j=1,3
         sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
C         print *,"jestem",scale_fac_dist,fac_help_scale,
C     &                    sh_frac_dist_grad(j)
         enddo
        endif
C        if ((i.eq.3).and.(k.eq.2)) then
C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
C     & ,"TU"
C        endif

C this is what is now we have the distance scaling now volume...
      short=short_r_sidechain(itype(k))
      long=long_r_sidechain(itype(k))
      costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
C now costhet_grad
C       costhet=0.0d0
       costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
C       costhet_fac=0.0d0
       do j=1,3
         costhet_grad(j)=costhet_fac*pep_side(j)
       enddo
C remember for the final gradient multiply costhet_grad(j) 
C for side_chain by factor -2 !
C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
C pep_side0pept_group is vector multiplication  
      pep_side0pept_group=0.0
      do j=1,3
      pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
      enddo
      cosalfa=(pep_side0pept_group/
     & (dist_pep_side*dist_side_calf))
      fac_alfa_sin=1.0-cosalfa**2
      fac_alfa_sin=dsqrt(fac_alfa_sin)
      rkprim=fac_alfa_sin*(long-short)+short
C now costhet_grad
       cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
       cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4

       do j=1,3
         cosphi_grad_long(j)=cosphi_fac*pep_side(j)
     &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
     &*(long-short)/fac_alfa_sin*cosalfa/
     &((dist_pep_side*dist_side_calf))*
     &((side_calf(j))-cosalfa*
     &((pep_side(j)/dist_pep_side)*dist_side_calf))

        cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
     &*(long-short)/fac_alfa_sin*cosalfa
     &/((dist_pep_side*dist_side_calf))*
     &(pep_side(j)-
     &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
       enddo

      VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
     &                    /VSolvSphere_div
     &                    *wshield
C now the gradient...
C grad_shield is gradient of Calfa for peptide groups
C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
C     &               costhet,cosphi
C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
      do j=1,3
      grad_shield(j,i)=grad_shield(j,i)
C gradient po skalowaniu
     &                +(sh_frac_dist_grad(j)
C  gradient po costhet
     &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
     &-scale_fac_dist*(cosphi_grad_long(j))
     &/(1.0-cosphi) )*div77_81
     &*VofOverlap
C grad_shield_side is Cbeta sidechain gradient
      grad_shield_side(j,ishield_list(i),i)=
     &        (sh_frac_dist_grad(j)*-2.0d0
     &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
     &       +scale_fac_dist*(cosphi_grad_long(j))
     &        *2.0d0/(1.0-cosphi))
     &        *div77_81*VofOverlap

       grad_shield_loc(j,ishield_list(i),i)=
     &   scale_fac_dist*cosphi_grad_loc(j)
     &        *2.0d0/(1.0-cosphi)
     &        *div77_81*VofOverlap
      enddo
      VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
      enddo
      fac_shield(i)=VolumeTotal*div77_81+div4_81
C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
      enddo
      return
      end
C--------------------------------------------------------------------------
C-----------------------------------------------------------------------
      double precision function sscalelip(r)
      double precision r,gamm
      include "COMMON.SPLITELE"
C      if(r.lt.r_cut-rlamb) then
C        sscale=1.0d0
C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
C        gamm=(r-(r_cut-rlamb))/rlamb
        sscalelip=1.0d0+r*r*(2*r-3.0d0)
C      else
C        sscale=0d0
C      endif
      return
      end
C-----------------------------------------------------------------------
      double precision function sscagradlip(r)
      double precision r,gamm
      include "COMMON.SPLITELE"
C     if(r.lt.r_cut-rlamb) then
C        sscagrad=0.0d0
C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
C        gamm=(r-(r_cut-rlamb))/rlamb
        sscagradlip=r*(6*r-6.0d0)
C      else
C        sscagrad=0.0d0
C      endif
      return
      end

C-----------------------------------------------------------------------
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      subroutine Eliptransfer(eliptran)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.IOUNITS'
      include 'COMMON.CALC'
      include 'COMMON.CONTROL'
      include 'COMMON.SPLITELE'
      include 'COMMON.SBRIDGE'
C this is done by Adasko
C      print *,"wchodze"
C structure of box:
C      water
C--bordliptop-- buffore starts
C--bufliptop--- here true lipid starts
C      lipid
C--buflipbot--- lipid ends buffore starts
C--bordlipbot--buffore ends
      eliptran=0.0
      write(iout,*) "I am in?"
      do i=1,nres
C       do i=1,1
        if (itype(i).eq.ntyp1) cycle

        positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
        if (positi.le.0) positi=positi+boxzsize
C        print *,i
C first for peptide groups
c for each residue check if it is in lipid or lipid water border area
       if ((positi.gt.bordlipbot)
     &.and.(positi.lt.bordliptop)) then
C the energy transfer exist
        if (positi.lt.buflipbot) then
C what fraction I am in
         fracinbuf=1.0d0-
     &        ((positi-bordlipbot)/lipbufthick)
C lipbufthick is thickenes of lipid buffore
         sslip=sscalelip(fracinbuf)
         ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
         eliptran=eliptran+sslip*pepliptran
         gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
         gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
        elseif (positi.gt.bufliptop) then
         fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
         sslip=sscalelip(fracinbuf)
         ssgradlip=sscagradlip(fracinbuf)/lipbufthick
         eliptran=eliptran+sslip*pepliptran
         gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
         gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
C          print *, "doing sscalefor top part"
C         print *,i,sslip,fracinbuf,ssgradlip
        else
         eliptran=eliptran+pepliptran
C         print *,"I am in true lipid"
        endif
C       else
C       eliptran=elpitran+0.0 ! I am in water
       endif
       enddo
C       print *, "nic nie bylo w lipidzie?"
C now multiply all by the peptide group transfer factor
C       eliptran=eliptran*pepliptran
C now the same for side chains
CV       do i=1,1
       do i=1,nres
        if (itype(i).eq.ntyp1) cycle
        positi=(mod(c(3,i+nres),boxzsize))
        if (positi.le.0) positi=positi+boxzsize
C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
c for each residue check if it is in lipid or lipid water border area
C       respos=mod(c(3,i+nres),boxzsize)
C       print *,positi,bordlipbot,buflipbot
       if ((positi.gt.bordlipbot)
     & .and.(positi.lt.bordliptop)) then
C the energy transfer exist
        if (positi.lt.buflipbot) then
         fracinbuf=1.0d0-
     &     ((positi-bordlipbot)/lipbufthick)
C lipbufthick is thickenes of lipid buffore
         sslip=sscalelip(fracinbuf)
         ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
         eliptran=eliptran+sslip*liptranene(itype(i))
         gliptranx(3,i)=gliptranx(3,i)
     &+ssgradlip*liptranene(itype(i))
         gliptranc(3,i-1)= gliptranc(3,i-1)
     &+ssgradlip*liptranene(itype(i))
C         print *,"doing sccale for lower part"
        elseif (positi.gt.bufliptop) then
         fracinbuf=1.0d0-
     &((bordliptop-positi)/lipbufthick)
         sslip=sscalelip(fracinbuf)
         ssgradlip=sscagradlip(fracinbuf)/lipbufthick
         eliptran=eliptran+sslip*liptranene(itype(i))
         gliptranx(3,i)=gliptranx(3,i)
     &+ssgradlip*liptranene(itype(i))
         gliptranc(3,i-1)= gliptranc(3,i-1)
     &+ssgradlip*liptranene(itype(i))
C          print *, "doing sscalefor top part",sslip,fracinbuf
        else
         eliptran=eliptran+liptranene(itype(i))
C         print *,"I am in true lipid"
        endif
        endif ! if in lipid or buffor
C       else
C       eliptran=elpitran+0.0 ! I am in water
       enddo
       return
       end
C-------------------------------------------------------------------------------------