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

#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)
      include 'COMMON.FFIELD'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.SBRIDGE'
      include 'COMMON.CHAIN'
      include 'COMMON.SHIELD'
      include 'COMMON.CONTROL'
      include 'COMMON.TORCNSTR'
      include 'COMMON.SAXS'
      double precision fact(6)
c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
c      call flush(iout)
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      write(iout,*) 'po elektostatyce'
C
C Calculate electrostatic (H-bonding) energy of the main chain.
C
  106 continue
      call vec_and_deriv
      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            write(iout,*) 'po eelec'

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
C      print *,'Bend energy finished.'
      if (wang.gt.0d0) then
       if (tor_mode.eq.0) then
         call ebend(ebe)
       else
C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
C energy function
         call ebend_kcc(ebe)
       endif
      else
        ebe=0.0d0
      endif
      ethetacnstr=0.0d0
      if (with_theta_constr) call etheta_constr(ethetacnstr)
c      call ebend(ebe,ethetacnstr)
cd    print *,'Bend energy finished.'
C
C Calculate the SC local energy.
C
      call esc(escloc)
C       print *,'SCLOC energy finished.'
C
C Calculate the virtual-bond torsional energy.
C
      if (wtor.gt.0.0d0) then
         if (tor_mode.eq.0) then
           call etor(etors,fact(1))
         else
C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
C energy function
           call etor_kcc(etors,fact(1))
         endif
      else
        etors=0.0d0
      endif
      edihcnstr=0.0d0
      if (ndih_constr.gt.0) call etor_constr(edihcnstr)
c      print *,"Processor",myrank," computed Utor"
C
C 6/23/01 Calculate double-torsional energy
C
      if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
        call etor_d(etors_d,fact(2))
      else
        etors_d=0
      endif
c      print *,"Processor",myrank," computed Utord"
C
      if (wsccor.gt.0.0d0) then
        call eback_sc_corr(esccor)
      else 
        esccor=0.0d0
      endif

      if (wliptran.gt.0) then
        call Eliptransfer(eliptran)
      else
        eliptran=0.0d0
      endif
#ifdef FOURBODY
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         write(iout,*)"calling multibody_eello"
         call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
c         write (iout,*) 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
c         write (iout,*) "Calling multibody_hbond"
         call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
      endif
#endif
c      write (iout,*) "nsaxs",nsaxs
c      write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
      if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
        call e_saxs(Esaxs_constr)
c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
      else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
        call e_saxsC(Esaxs_constr)
c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
      else
        Esaxs_constr = 0.0d0
      endif

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

c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
#ifdef DFA
C     BARTEK for dfa test!
      edfadis=0.0d0
      if (wdfa_dist.gt.0) call edfad(edfadis)
c      write(iout,*)'edfad is finished!', wdfa_dist,edfadis
      edfator=0.0d0
      if (wdfa_tor.gt.0) call edfat(edfator)
c      write(iout,*)'edfat is finished!', wdfa_tor,edfator
      edfanei=0.0d0
      if (wdfa_nei.gt.0) call edfan(edfanei)
c      write(iout,*)'edfan is finished!', wdfa_nei,edfanei
      edfabet=0.0d0
      if (wdfa_beta.gt.0) call edfab(edfabet)
c      write(iout,*)'edfab is finished!', wdfa_beta,edfabet
#else
      edfadis=0.0d0
      edfator=0.0d0
      edfanei=0.0d0
      edfabet=0.0d0
#endif
c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
#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+wsaxs*esaxs_constr
     & +wliptran*eliptran*esaxs_constr
     & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
     & +wdfa_beta*edfabet
      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+ethetacnstr
     & +wliptran*eliptran+wsaxs*esaxs_constr
     & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
     & +wdfa_beta*edfabet
      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+ethetacnstr
     & +wliptran*eliptran+wsaxs*esaxs_constr
     & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
     & +wdfa_beta*edfabet
      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+wsaxs*esaxs_constr
     & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
     & +wdfa_beta*edfabet
      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(21)=evdw_t
      energia(22)=eliptran
      energia(24)=ethetacnstr
      energia(26)=esaxs_constr
      energia(27)=ehomology_constr
      energia(28)=edfadis
      energia(29)=edfator
      energia(30)=edfanei
      energia(31)=edfabet
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
#ifdef DEBUG
      call enerprint(energia,fact)
#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)+
     &                wdfa_dist*gdfad(j,i)+
     &                wdfa_tor*gdfat(j,i)+
     &                wdfa_nei*gdfan(j,i)+
     &                wdfa_beta*gdfab(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)+
     &                wdfa_dist*gdfad(j,i)+
     &                wdfa_tor*gdfat(j,i)+
     &                wdfa_nei*gdfan(j,i)+
     &                wdfa_beta*gdfab(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)+
     &                wdfa_dist*gdfad(j,i)+
     &                wdfa_tor*gdfat(j,i)+
     &                wdfa_nei*gdfan(j,i)+
     &                wdfa_beta*gdfab(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)
     &                 +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)+
     &                wdfa_dist*gdfad(j,i)+
     &                wdfa_tor*gdfat(j,i)+
     &                wdfa_nei*gdfan(j,i)+
     &                wdfa_beta*gdfab(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)
     &                 +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
#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 BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
      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 'DIMENSIONS.ZSCOPT'
      include 'COMMON.IOUNITS'
      include 'COMMON.FFIELD'
      include 'COMMON.SBRIDGE'
      include 'COMMON.CONTROL'
      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)
      ethetacnstr=energia(24)
      eliptran=energia(22)
      esaxs=energia(26)
      ehomology_constr=energia(27)
C     Bartek
      edfadis = energia(28)
      edfator = energia(29)
      edfanei = energia(30)
      edfabet = energia(31)
      Eafmforc=0.0d0
      etube=0.0d0
      Uconst=0.0d0
#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,
#ifdef FOURBODY
     &  ecorr,wcorr*fact(3),
     &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
#endif
     &  eel_loc,
     &  wel_loc*fact(2),eello_turn3,wturn3*fact(2),
     &  eello_turn4,wturn4*fact(3),
#ifdef FOURBODY
     &  eello_turn6,wturn6*fact(5),
#endif
     &  esccor,wsccor*fact(1),edihcnstr,
     &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
     &  etube,wtube,esaxs,wsaxs,ehomology_constr,
     &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
     &  edfabet,wdfa_beta,
     &  etot
   10 format (/'Virtual-chain energies:'//
     & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
     & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
     & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
     & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
     & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
     & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
     & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
     & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
     & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
     & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
     & ' (SS bridges & dist. cnstr.)'/
#ifdef FOURBODY
     & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
     & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
     & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
#endif
     & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
     & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
     & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
#ifdef FOURBODY
     & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
#endif
     & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
     & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
     & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
     & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
     & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/ 
     & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
     & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
     & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
     & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
     & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
     & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
     & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
     & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
     & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta 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*fact(2),ehpb,wstrain,
#ifdef FOURBODY
     &  ecorr,wcorr*fact(3),
     &  ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
#endif
     &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
     &  eello_turn4,wturn4*fact(3),
#ifdef FOURBODY
     &  eello_turn6,wturn6*fact(5),
#endif
     &  esccor,wsccor*fact(1),edihcnstr,
     &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
     &  etube,wtube,esaxs,wsaxs,ehomology_constr,
     &  edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
     &  edfabet,wdfa_beta,
     &  etot
   10 format (/'Virtual-chain energies:'//
     & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
     & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
     & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
     & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
     & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
     & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
     & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
     & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
     & 'EHBP=  ',1pE16.6,' WEIGHT=',1pE16.6,
     & ' (SS bridges & dist. restr.)'/
#ifdef FOURBODY
     & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
     & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
     & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
#endif
     & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
     & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
     & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
#ifdef FOURBODY
     & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
#endif
     & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
     & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
     & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
     & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
     & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/ 
     & 'ELT=   ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
     & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
     & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
     & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
     & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
     & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
     & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
     & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
     & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta 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 'DIMENSIONS.ZSCOPT'
      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.ENEPS'
      include 'COMMON.SBRIDGE'
      include 'COMMON.NAMES'
      include 'COMMON.IOUNITS'
#ifdef FOURBODY
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
#endif
      dimension gg(3)
      integer icant
      external icant
cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
c ROZNICA z cluster
      do i=1,210
        do j=1,2
          eneps_temp(j,i)=0.0d0
        enddo
      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)
        call to_box(xi,yi,zi)
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
            call to_box(xj,yj,zj)
            xj=boxshift(xj-xi,boxxsize)
            yj=boxshift(yj-yi,boxysize)
            zj=boxshift(zj-zi,boxzsize)
C Change 12/1/95 to calculate four-body interactions
            rij=xj*xj+yj*yj+zj*zj
            rrij=1.0D0/rij
            sqrij=dsqrt(rij)
            sss1=sscale(sqrij)
            if (sss1.eq.0.0d0) cycle
            sssgrad1=sscagrad(sqrij)
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 cluster
            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
            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+sss1*evdwij
            else
              evdw_t=evdw_t+sss1*evdwij
            endif
            if (calc_grad) then
C 
C Calculate the components of the gradient in DC and X
C
            fac=-rrij*(e1+evdwij)*sss1
     &          +evdwij*sssgrad1/sqrij/expon
            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
#ifdef FOURBODY
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
#endif
          enddo      ! j
        enddo        ! iint
#ifdef FOURBODY
C Change 12/1/95
        num_cont(i)=num_conti
#endif
      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 'DIMENSIONS.ZSCOPT'
      include "DIMENSIONS.COMPAR"
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.ENEPS'
      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
      do i=1,210
        do j=1,2
          eneps_temp(j,i)=0.0d0
        enddo
      enddo
      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)
        call to_box(xi,yi,zi)
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
            call to_box(xj,yj,zj)
            xj=boxshift(xj-xi,boxxsize)
            yj=boxshift(yj-yi,boxysize)
            zj=boxshift(zj-zi,boxzsize)
            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 
            sss1=sscale(rij)
            if (sss1.eq.0.0d0) cycle
            sssgrad1=sscagrad(rij)
            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)
            eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
     &        /dabs(eps(itypi,itypj))
            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(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*sss1
            else 
              evdw_t=evdw_t+evdwij*sss1
            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))*sss1
     &          +evdwij*sssgrad1*r_inv_ij/expon
            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 'DIMENSIONS.ZSCOPT'
      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.ENEPS'
      include 'COMMON.IOUNITS'
      include 'COMMON.CALC'
      common /srutu/ icall
c     double precision rrsave(maxdim)
      logical lprn
      integer icant
      external icant
      do i=1,210
        do j=1,2
          eneps_temp(j,i)=0.0d0
        enddo
      enddo
      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)
        call to_box(xi,yi,zi)
        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)
            yj=c(2,nres+j)
            zj=c(3,nres+j)
            call to_box(xj,yj,zj)
            xj=boxshift(xj-xi,boxxsize)
            yj=boxshift(yj-yi,boxysize)
            zj=boxshift(zj-zi,boxzsize)
            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)
            sss1=sscale(1.0d0/rij)
            if (sss1.eq.0.0d0) cycle
            sssgrad1=sscagrad(1.0d0/rij)

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
            eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
     &        /dabs(eps(itypi,itypj))
            eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
            if (bb.gt.0.0d0) then
              evdw=evdw+sss1*evdwij
            else
              evdw_t=evdw_t+sss1*evdwij
            endif
            if (calc_grad) then
            if (lprn) then
            sigm=dabs(aa/bb)**(1.0D0/6.0D0)
            epsi=bb**2/aa
            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
     &        restyp(itypi),i,restyp(itypj),j,
     &        epsi,sigm,chi1,chi2,chip1,chip2,
     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
     &        om1,om2,om12,1.0D0/dsqrt(rrij),
     &        evdwij
            endif
C Calculate gradient components.
            e1=e1*eps1*eps2rt**2*eps3rt**2
            fac=-expon*(e1+evdwij)
            sigder=fac/sigsq
            fac=rrij*fac
     &           +evdwij*sssgrad1/sss1*rij
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 'DIMENSIONS.ZSCOPT'
      include "DIMENSIONS.COMPAR"
      include 'COMMON.CONTROL'
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.NAMES'
      include 'COMMON.INTERACT'
      include 'COMMON.ENEPS'
      include 'COMMON.IOUNITS'
      include 'COMMON.CALC'
      include 'COMMON.SBRIDGE'
      logical lprn
      common /srutu/icall
      integer icant,xshift,yshift,zshift
      external icant
      do i=1,210
        do j=1,2
          eneps_temp(j,i)=0.0d0
        enddo
      enddo
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)
C returning the ith atom to box
        call to_box(xi,yi,zi)
        call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
        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
              call dyn_ssbond_ene(i,j,evdwij)
              evdw=evdw+evdwij
C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
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
              call triple_ssbond_ene(i,j,k,evdwij)
C call the energy function that removes the artifical triple disulfide
C bond the soubroutine is located in ssMD.F
              evdw=evdw+evdwij
C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
              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)
C returning jth atom to box
            call to_box(xj,yj,zj)
            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
            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
            xj=boxshift(xj-xi,boxxsize)
            yj=boxshift(yj-yi,boxysize)
            zj=boxshift(zj-zi,boxzsize)
            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)
            sssgrad=sscagrad(1.0d0/rij)
            if (sss.le.0.0) 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
            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
     &        /dabs(eps(itypi,itypj))
            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
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
            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
     &        restyp(itypi),i,restyp(itypj),j,
     &        epsi,sigm,chi1,chi2,chip1,chip2,
     &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
     &        evdwij
             write (iout,*) "partial sum", evdw, evdw_t
#endif
c#undef DEBUG
c            endif
            if (energy_dec) write (iout,'(a,2i5,3f10.5)')
     &                    'r sss evdw',i,j,1.0d0/rij,sss,evdwij
            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
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
C            write(iout,*)  "partial sum", evdw, evdw_t
            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 'DIMENSIONS.ZSCOPT'
      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.ENEPS'
      include 'COMMON.IOUNITS'
      include 'COMMON.CALC'
      common /srutu/ icall
      logical lprn
      integer icant
      external icant
      do i=1,210
        do j=1,2
          eneps_temp(j,i)=0.0d0
        enddo
      enddo
      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)
        call to_box(xi,yi,zi)
        call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
        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)
            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)
            call to_box(xj,yj,zj)
            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
            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      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
            xj=boxshift(xj-xi,boxxsize)
            yj=boxshift(yj-yi,boxysize)
            zj=boxshift(zj-zi,boxzsize)
            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)
            sss=sscale(1.0d0/rij)
            if (sss.eq.0.0d0) cycle
            sssgrad=sscagrad(1.0d0/rij)
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)*sss
            else
              evdw_t=evdw_t+(evdwij+e_augm)*sss
            endif
            ij=icant(itypi,itypj)
            aux=eps1*eps2rt**2*eps3rt**2
            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
     &        /dabs(eps(itypi,itypj))
            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
c            eneps_temp(ij)=eneps_temp(ij)
c     &         +(evdwij+e_augm)/eps(itypi,itypj)
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
            fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
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 'DIMENSIONS.ZSCOPT'
      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)
     &            +(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)
     &            +(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)
        enddo
      enddo
      return
      end
c------------------------------------------------------------------------------
      subroutine vec_and_deriv
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      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)
c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
c     &         " uz",uz(:,i)
            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 ! calc_grad
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 set_matrices
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
#ifdef MPI
      include "mpif.h"
      integer IERR
      integer status(MPI_STATUS_SIZE)
#endif
      include 'DIMENSIONS.ZSCOPT'
      include 'COMMON.IOUNITS'
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CORRMAT'
      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
c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
      do i=3,nres+1
        ii=ireschain(i-2)
        if (ii.eq.0) cycle
        innt=chain_border(1,ii)
        inct=chain_border(2,ii)
c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
        if (i.gt. innt+2 .and. i.lt.inct+2) then
          iti = itype2loc(itype(i-2))
        else
          iti=nloctyp
        endif
c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
        if (i.gt. innt+1 .and. i.lt.inct+1) then
          iti1 = itype2loc(itype(i-1))
        else
          iti1=nloctyp
        endif
#ifdef NEWCORR
        cost1=dcos(theta(i-1))
        sint1=dsin(theta(i-1))
        sint1sq=sint1*sint1
        sint1cub=sint1sq*sint1
        sint1cost1=2*sint1*cost1
#ifdef DEBUG
        write (iout,*) "bnew1",i,iti
        write (iout,*) (bnew1(k,1,iti),k=1,3)
        write (iout,*) (bnew1(k,2,iti),k=1,3)
        write (iout,*) "bnew2",i,iti
        write (iout,*) (bnew2(k,1,iti),k=1,3)
        write (iout,*) (bnew2(k,2,iti),k=1,3)
#endif
        do k=1,2
          b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
          b1(k,i-2)=sint1*b1k
          gtb1(k,i-2)=cost1*b1k-sint1sq*
     &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
          b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
          b2(k,i-2)=sint1*b2k
          if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
     &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
        enddo
        do k=1,2
          aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
          cc(1,k,i-2)=sint1sq*aux
          if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
     &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
          aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
          dd(1,k,i-2)=sint1sq*aux
          if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
     &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
        enddo
        cc(2,1,i-2)=cc(1,2,i-2)
        cc(2,2,i-2)=-cc(1,1,i-2)
        gtcc(2,1,i-2)=gtcc(1,2,i-2)
        gtcc(2,2,i-2)=-gtcc(1,1,i-2)
        dd(2,1,i-2)=dd(1,2,i-2)
        dd(2,2,i-2)=-dd(1,1,i-2)
        gtdd(2,1,i-2)=gtdd(1,2,i-2)
        gtdd(2,2,i-2)=-gtdd(1,1,i-2)
        do k=1,2
          do l=1,2
            aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
            EE(l,k,i-2)=sint1sq*aux
            if (calc_grad) 
     &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
          enddo
        enddo
        EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
        EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
        EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
        EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
        if (calc_grad) then
        gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
        gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
        gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
        endif
c        b1tilde(1,i-2)=b1(1,i-2)
c        b1tilde(2,i-2)=-b1(2,i-2)
c        b2tilde(1,i-2)=b2(1,i-2)
c        b2tilde(2,i-2)=-b2(2,i-2)
#ifdef DEBUG
        write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
        write (iout,*) 'theta=', theta(i-1)
#endif
#else
c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
c          iti = itype2loc(itype(i-2))
c        else
c          iti=nloctyp
c        endif
c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
c          iti1 = itype2loc(itype(i-1))
c        else
c          iti1=nloctyp
c        endif
        b1(1,i-2)=b(3,iti)
        b1(2,i-2)=b(5,iti)
        b2(1,i-2)=b(2,iti)
        b2(2,i-2)=b(4,iti)
        do k=1,2
          do l=1,2
           CC(k,l,i-2)=ccold(k,l,iti)
           DD(k,l,i-2)=ddold(k,l,iti)
           EE(k,l,i-2)=eeold(k,l,iti)
          enddo
        enddo
#endif
        b1tilde(1,i-2)= b1(1,i-2)
        b1tilde(2,i-2)=-b1(2,i-2)
        b2tilde(1,i-2)= b2(1,i-2)
        b2tilde(2,i-2)=-b2(2,i-2)
c
        Ctilde(1,1,i-2)= CC(1,1,i-2)
        Ctilde(1,2,i-2)= CC(1,2,i-2)
        Ctilde(2,1,i-2)=-CC(2,1,i-2)
        Ctilde(2,2,i-2)=-CC(2,2,i-2)
c
        Dtilde(1,1,i-2)= DD(1,1,i-2)
        Dtilde(1,2,i-2)= DD(1,2,i-2)
        Dtilde(2,1,i-2)=-DD(2,1,i-2)
        Dtilde(2,2,i-2)=-DD(2,2,i-2)
#ifdef DEBUG
        write(iout,*) "i",i," iti",iti
        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
#endif
      enddo
      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
c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
        if (i.gt. nnt+2 .and. i.lt.nct+2) then
          iti = itype2loc(itype(i-2))
        else
          iti=nloctyp
        endif
c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
        if (i.gt. nnt+1 .and. i.lt.nct+1) then
          iti1 = itype2loc(itype(i-1))
        else
          iti1=nloctyp
        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        if (i .gt. iatel_s+2) then
        if (i .gt. nnt+2) then
          call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
#ifdef NEWCORR
          call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
#endif
c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
c     &    EE(1,2,iti),EE(2,2,i)
          call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
          call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
c          write(iout,*) "Macierz EUG",
c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
c     &    eug(2,2,i-2)
#ifdef FOURBODY
          if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) 
     &    then
          call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
          call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
          call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
          call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
          call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
          endif
#endif
        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
        call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
        call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
        do k=1,2
          muder(k,i-2)=Ub2der(k,i-2)
        enddo
c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
        if (i.gt. nnt+1 .and. i.lt.nct+1) then
          if (itype(i-1).le.ntyp) then
            iti1 = itype2loc(itype(i-1))
          else
            iti1=nloctyp
          endif
        else
          iti1=nloctyp
        endif
        do k=1,2
          mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
        enddo
#ifdef MUOUT
        write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
     &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
     &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
     &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
     &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
     &      ((ee(l,k,i-2),l=1,2),k=1,2)
#endif
cd        write (iout,*) 'mu1',mu1(:,i-2)
cd        write (iout,*) 'mu2',mu2(:,i-2)
#ifdef FOURBODY
        if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
     &  then  
        if (calc_grad) then
        call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
        call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
        call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
        call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
        call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
        endif
C Vectors and matrices dependent on a single virtual-bond dihedral.
        call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
        call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2)) 
        call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
        call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
        call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
        if (calc_grad) then
        call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2)) 
        call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
        call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
        call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
        endif
        endif
#endif
      enddo
#ifdef FOURBODY
C Matrices dependent on two consecutive virtual-bond dihedrals.
C The order of matrices is from left to right.
      if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
     &then
      do i=2,nres-1
        call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
        if (calc_grad) then
        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))
        endif
        call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
        call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
        if (calc_grad) then
        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))
        endif
      enddo
      endif
#endif
      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)
#ifdef MPI
      include 'mpif.h'
#endif
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      include 'COMMON.CONTROL'
      include 'COMMON.IOUNITS'
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
#ifdef FOURBODY
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
#endif
      include 'COMMON.CORRMAT'
      include 'COMMON.TORSION'
      include 'COMMON.VECTORS'
      include 'COMMON.FFIELD'
      include 'COMMON.TIME1'
      include 'COMMON.SPLITELE'
      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),gmuij(4)
      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
     &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
     &    num_conti,j1,j2
c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
#ifdef MOMENT
      double precision scal_el /1.0d0/
#else
      double precision scal_el /0.5d0/
#endif
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
c        call vec_and_deriv
#ifdef TIMING
        time01=MPI_Wtime()
#endif
        call set_matrices
#ifdef TIMING
        time_mat=time_mat+MPI_Wtime()-time01
#endif
      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
      t_eelecij=0.0d0
      ees=0.0D0
      evdw1=0.0D0
      eel_loc=0.0d0 
      eello_turn3=0.0d0
      eello_turn4=0.0d0
      ind=0
#ifdef FOURBODY
      do i=1,nres
        num_cont_hb(i)=0
      enddo
#endif
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
c
c
c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
C
C Loop over i,i+2 and i,i+3 pairs of the peptide groups
C
C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
      do i=iturn3_start,iturn3_end
c        if (i.le.1) cycle
C        write(iout,*) "tu jest i",i
        if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
C changes suggested by Ana to avoid out of bounds
C Adam: Unnecessary: handled by iturn3_end and iturn3_start
c     & .or.((i+4).gt.nres)
c     & .or.((i-1).le.0)
C end of changes by Ana
C dobra zmiana wycofana
     &  .or. itype(i+2).eq.ntyp1
     &  .or. itype(i+3).eq.ntyp1) cycle
C Adam: Instructions below will switch off existing interactions
c        if(i.gt.1)then
c          if(itype(i-1).eq.ntyp1)cycle
c        end if
c        if(i.LT.nres-3)then
c          if (itype(i+4).eq.ntyp1) cycle
c        end if
        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
        call to_box(xmedi,ymedi,zmedi)
        num_conti=0
        call eelecij(i,i+2,ees,evdw1,eel_loc)
        if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
#ifdef FOURBODY
        num_cont_hb(i)=num_conti
#endif
      enddo
      do i=iturn4_start,iturn4_end
        if (i.lt.1) cycle
        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
c     &    .or. itype(i).eq.ntyp1
c     &    .or. itype(i-1).eq.ntyp1
     &                             ) cycle
        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
        call to_box(xmedi,ymedi,zmedi)
#ifdef FOURBODY
        num_conti=num_cont_hb(i)
#endif
c        write(iout,*) "JESTEM W PETLI"
        call eelecij(i,i+3,ees,evdw1,eel_loc)
        if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) 
     &   call eturn4(i,eello_turn4)
#ifdef FOURBODY
        num_cont_hb(i)=num_conti
#endif
      enddo   ! i
C Loop over all neighbouring boxes
C      do xshift=-1,1
C      do yshift=-1,1
C      do zshift=-1,1
c
c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
c
CTU KURWA
      do i=iatel_s,iatel_e
C        do i=75,75
c        if (i.le.1) cycle
        if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
C changes suggested by Ana to avoid out of bounds
c     & .or.((i+2).gt.nres)
c     & .or.((i-1).le.0)
C end of changes by Ana
c     &  .or. itype(i+2).eq.ntyp1
c     &  .or. itype(i-1).eq.ntyp1
     &                ) cycle
        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
        call to_box(xmedi,ymedi,zmedi)
#ifdef FOURBODY
        num_conti=num_cont_hb(i)
#endif
C I TU KURWA
        do j=ielstart(i),ielend(i)
C          do j=16,17
C          write (iout,*) i,j
C         if (j.le.1) cycle
          if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
C changes suggested by Ana to avoid out of bounds
c     & .or.((j+2).gt.nres)
c     & .or.((j-1).le.0)
C end of changes by Ana
c     & .or.itype(j+2).eq.ntyp1
c     & .or.itype(j-1).eq.ntyp1
     &) cycle
          call eelecij(i,j,ees,evdw1,eel_loc)
        enddo ! j
#ifdef FOURBODY
        num_cont_hb(i)=num_conti
#endif
      enddo   ! i
C     enddo   ! zshift
C      enddo   ! yshift
C      enddo   ! xshift

c      write (iout,*) "Number of loop steps in EELEC:",ind
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
cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
      return
      end
C-------------------------------------------------------------------------------
      subroutine eelecij(i,j,ees,evdw1,eel_loc)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
#ifdef MPI
      include "mpif.h"
#endif
      include 'COMMON.CONTROL'
      include 'COMMON.IOUNITS'
      include 'COMMON.GEO'
      include 'COMMON.VAR'
      include 'COMMON.LOCAL'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
#ifdef FOURBODY
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
#endif
      include 'COMMON.CORRMAT'
      include 'COMMON.TORSION'
      include 'COMMON.VECTORS'
      include 'COMMON.FFIELD'
      include 'COMMON.TIME1'
      include 'COMMON.SPLITELE'
      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),gmuij1(4),gmuji1(4),
     &    gmuij2(4),gmuji2(4)
      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
     &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
     &    num_conti,j1,j2
c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
#ifdef MOMENT
      double precision scal_el /1.0d0/
#else
      double precision scal_el /0.5d0/
#endif
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/
       integer xshift,yshift,zshift
c          time00=MPI_Wtime()
cd      write (iout,*) "eelecij",i,j
c          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)
          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)
C          xj=c(1,j)+0.5D0*dxj-xmedi
C          yj=c(2,j)+0.5D0*dyj-ymedi
C          zj=c(3,j)+0.5D0*dzj-zmedi
          xj=c(1,j)+0.5D0*dxj
          yj=c(2,j)+0.5D0*dyj
          zj=c(3,j)+0.5D0*dzj
          call to_box(xj,yj,zj)
          xj=boxshift(xj-xmedi,boxxsize)
          yj=boxshift(yj-ymedi,boxysize)
          zj=boxshift(zj-zmedi,boxzsize)
          rij=xj*xj+yj*yj+zj*zj

          sss=sscale(sqrt(rij))
          if (sss.eq.0.0d0) return
          sssgrad=sscagrad(sqrt(rij))
c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
c     &       " rlamb",rlamb," sss",sss
c            if (sss.gt.0.0d0) then  
          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       
C MARYSIA
C          eesij=(el1+el2)
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
          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
          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

          if (energy_dec) then 
              write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)') 
     &'evdw1',i,j,evdwij
     &,iteli,itelj,aaa,evdw1,sss
              write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
     &fac_shield(i),fac_shield(j)
          endif

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

*
* Radial derivatives. First process both termini of the fragment (i,j)
*
          if (calc_grad) then
          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
           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

C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
C             if (iresshield.gt.j) then
C               do ishi=j+1,iresshield-1
C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
C
C               enddo
C            else
C               do ishi=iresshield,j
C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
C               enddo
C              endif
           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
c          do k=1,3
c            ghalf=0.5D0*ggg(k)
c            gelc(k,i)=gelc(k,i)+ghalf
c            gelc(k,j)=gelc(k,j)+ghalf
c          enddo
c 9/28/08 AL Gradient compotents will be summed only at the end
C           print *,"before", gelc_long(1,i), gelc_long(1,j)
          do k=1,3
            gelc_long(k,j)=gelc_long(k,j)+ggg(k)
C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
            gelc_long(k,i)=gelc_long(k,i)-ggg(k)
C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
C            gelc_long(k,i-1)=gelc_long(k,i-1)
C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
C            gelc_long(k,j-1)=gelc_long(k,j-1)
C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
          enddo
C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)

*
* Loop over residues i+1 thru j-1.
*
cgrad          do k=i+1,j-1
cgrad            do l=1,3
cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
cgrad            enddo
cgrad          enddo
          if (sss.gt.0.0) then
          facvdw=facvdw+sssgrad*rmij*evdwij
          ggg(1)=facvdw*xj
          ggg(2)=facvdw*yj
          ggg(3)=facvdw*zj
          else
          ggg(1)=0.0
          ggg(2)=0.0
          ggg(3)=0.0
          endif
c          do k=1,3
c            ghalf=0.5D0*ggg(k)
c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
c          enddo
c 9/28/08 AL Gradient compotents will be summed only at the end
          do k=1,3
            gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
            gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
          enddo
*
* Loop over residues i+1 thru j-1.
*
cgrad          do k=i+1,j-1
cgrad            do l=1,3
cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
cgrad            enddo
cgrad          enddo
          endif ! calc_grad
#else
C MARYSIA
          facvdw=(ev1+evdwij)
          facel=(el1+eesij)
          fac1=fac
          fac=-3*rrmij*(facvdw+facvdw+facel)*sss
     &       +(evdwij+eesij)*sssgrad*rrmij
          erij(1)=xj*rmij
          erij(2)=yj*rmij
          erij(3)=zj*rmij
*
* Radial derivatives. First process both termini of the fragment (i,j)
* 
          if (calc_grad) then
          ggg(1)=fac*xj
C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
          ggg(2)=fac*yj
C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
          ggg(3)=fac*zj
C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
c          do k=1,3
c            ghalf=0.5D0*ggg(k)
c            gelc(k,i)=gelc(k,i)+ghalf
c            gelc(k,j)=gelc(k,j)+ghalf
c          enddo
c 9/28/08 AL Gradient compotents will be summed only at the end
          do k=1,3
            gelc_long(k,j)=gelc(k,j)+ggg(k)
            gelc_long(k,i)=gelc(k,i)-ggg(k)
          enddo
*
* Loop over residues i+1 thru j-1.
*
cgrad          do k=i+1,j-1
cgrad            do l=1,3
cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
cgrad            enddo
cgrad          enddo
c 9/28/08 AL Gradient compotents will be summed only at the end
          ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
          ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
          ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
          do k=1,3
            gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
            gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
          enddo
          endif ! calc_grad
#endif
*
* Angular part
*          
          if (calc_grad) then
          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
c          do k=1,3
c            ghalf=0.5D0*ggg(k)
c            gelc(k,i)=gelc(k,i)+ghalf
c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
c            gelc(k,j)=gelc(k,j)+ghalf
c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
c          enddo
cgrad          do k=i+1,j-1
cgrad            do l=1,3
cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
cgrad            enddo
cgrad          enddo
C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
          do k=1,3
            gelc(k,i)=gelc(k,i)
     &           +((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)
     &           +((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
            gelc_long(k,j)=gelc_long(k,j)+ggg(k)
            gelc_long(k,i)=gelc_long(k,i)-ggg(k)
          enddo
C           print *,"before33", gelc_long(1,i), gelc_long(1,j)

C MARYSIA
c          endif !sscale
          endif ! calc_grad
          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
          lll=0
          do k=1,2
            do l=1,2
              kkk=kkk+1
              muij(kkk)=mu(k,i)*mu(l,j)
c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
#ifdef NEWCORR
             if (calc_grad) then
             gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
             gmuij2(kkk)=gUb2(k,i)*mu(l,j)
             gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
             gmuji2(kkk)=mu(k,i)*gUb2(l,j)
             endif
#endif
            enddo
          enddo  
#ifdef DEBUG
          write (iout,*) 'EELEC: i',i,' j',j
          write (iout,*) 'j',j,' j1',j1,' j2',j2
          write(iout,*) 'muij',muij
          write (iout,*) "uy",uy(:,i)
          write (iout,*) "uz",uz(:,j)
          write (iout,*) "erij",erij
#endif
          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
          fac=dsqrt(-ael6i)*r3ij
          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(:,i),uz(:,i),
cd     &      uy(:,j),uz(:,j)
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,'(9f10.5/)') 
cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
C Derivatives of the elements of A in virtual-bond vectors
          if (calc_grad) then
          call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
          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
C Compute radial contributions to the gradient
          facr=-3.0d0*rrmij
          a22der=a22*facr
          a23der=a23*facr
          a32der=a32*facr
          a33der=a33*facr
          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) 
cgrad            ghalf1=0.5d0*agg(k,1)
cgrad            ghalf2=0.5d0*agg(k,2)
cgrad            ghalf3=0.5d0*agg(k,3)
cgrad            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)
cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
cgrad              do l=1,4
cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
cgrad              enddo
cgrad            endif
          enddo
          endif ! calc_grad
          acipa(1,1)=a22
          acipa(1,2)=a23
          acipa(2,1)=a32
          acipa(2,2)=a33
          a22=-a22
          a23=-a23
          if (calc_grad) then
          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
          endif ! calc_grad
          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
          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)
#ifdef DEBUG
          write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
     &     " a33",a33
          write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
     &     " wel_loc",wel_loc
#endif
          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)*sss
          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
     &            'eelloc',i,j,eel_loc_ij
c           if (eel_loc_ij.ne.0)
c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)

          eel_loc=eel_loc+eel_loc_ij
C Now derivative over eel_loc
          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


c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
c     &                     ' eel_loc_ij',eel_loc_ij
C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
C Calculate patrial derivative for theta angle
#ifdef NEWCORR
         geel_loc_ij=(a22*gmuij1(1)
     &     +a23*gmuij1(2)
     &     +a32*gmuij1(3)
     &     +a33*gmuij1(4))
     &    *fac_shield(i)*fac_shield(j)*sss
c         write(iout,*) "derivative over thatai"
c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
c     &   a33*gmuij1(4) 
         gloc(nphi+i,icg)=gloc(nphi+i,icg)+
     &      geel_loc_ij*wel_loc
c         write(iout,*) "derivative over thatai-1" 
c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
c     &   a33*gmuij2(4)
         geel_loc_ij=
     &     a22*gmuij2(1)
     &     +a23*gmuij2(2)
     &     +a32*gmuij2(3)
     &     +a33*gmuij2(4)
         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
     &      geel_loc_ij*wel_loc
     &    *fac_shield(i)*fac_shield(j)*sss

c  Derivative over j residue
         geel_loc_ji=a22*gmuji1(1)
     &     +a23*gmuji1(2)
     &     +a32*gmuji1(3)
     &     +a33*gmuji1(4)
c         write(iout,*) "derivative over thataj" 
c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
c     &   a33*gmuji1(4)

        gloc(nphi+j,icg)=gloc(nphi+j,icg)+
     &      geel_loc_ji*wel_loc
     &    *fac_shield(i)*fac_shield(j)

         geel_loc_ji=
     &     +a22*gmuji2(1)
     &     +a23*gmuji2(2)
     &     +a32*gmuji2(3)
     &     +a33*gmuji2(4)
c         write(iout,*) "derivative over thataj-1"
c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
c     &   a33*gmuji2(4)
         gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
     &      geel_loc_ji*wel_loc
     &    *fac_shield(i)*fac_shield(j)*sss
#endif
cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij

C Partial derivatives in virtual-bond dihedral angles gamma
          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)
C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
          aux=eel_loc_ij/sss*sssgrad*rmij
          ggg(1)=aux*xj
          ggg(2)=aux*yj
          ggg(3)=aux*zj
          do l=1,3
            ggg(l)=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)*sss
            gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
            gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
cgrad            ghalf=0.5d0*ggg(l)
cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
          enddo
cgrad          do k=i+1,j2
cgrad            do l=1,3
cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
cgrad            enddo
cgrad          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 ! calc_grad
          ENDIF


C Change 12/26/95 to calculate four-body contributions to H-bonding energy
c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
#ifdef FOURBODY
          if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
     &       .and. num_conti.le.maxconts) then
c            write (iout,*) i,j," entered corr"
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
cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
cd     &           " jcont_hb",jcont_hb(num_conti,i)
                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
                if (calc_grad) then
                do kkk=1,3
                  grij_hb_cont(kkk,num_conti,i)=erij(kkk)
                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)
                    enddo
                  enddo
                enddo
                endif ! calc_grad
                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
c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
                ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
                if (ees0tmp.gt.0) then
                  ees0pij=dsqrt(ees0tmp)
                else
                  ees0pij=0
                endif
c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
                ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
                if (ees0tmp.gt.0) then
                  ees0mij=dsqrt(ees0tmp)
                else
                  ees0mij=0
                endif
c               ees0mij=0.0D0
                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
                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
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
                facont_hb(num_conti,i)=fcont

                if (calc_grad) then
                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
     &          +ees0p(num_conti,i)/sss*rmij*xj*sssgrad                
                gggp(2)=gggp(2)+ees0pijp*yj
     &          +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
                gggp(3)=gggp(3)+ees0pijp*zj
     &          +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
                gggm(1)=gggm(1)+ees0mijp*xj
     &          +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
                gggm(2)=gggm(2)+ees0mijp*yj
     &          +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
                gggm(3)=gggm(3)+ees0mijp*zj
     &          +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
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
c
c 10/24/08 cgrad and ! comments indicate the parts of the code removed 
c          following the change of gradient-summation algorithm.
c
cgrad                  ghalfp=0.5D0*gggp(k)
cgrad                  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)*sss

                  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)*sss

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

                  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)*sss

                  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)*sss

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

                enddo
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 ! calc_grad

              ENDIF ! wcorr
              endif  ! num_conti.le.maxconts
            endif  ! fcont.gt.0
          endif    ! j.gt.i+1
#endif
          if (calc_grad) then
          if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
            do k=1,4
              do l=1,3
                ghalf=0.5d0*agg(l,k)
                aggi(l,k)=aggi(l,k)+ghalf
                aggi1(l,k)=aggi1(l,k)+agg(l,k)
                aggj(l,k)=aggj(l,k)+ghalf
              enddo
            enddo
            if (j.eq.nres-1 .and. i.lt.j-2) then
              do k=1,4
                do l=1,3
                  aggj1(l,k)=aggj1(l,k)+agg(l,k)
                enddo
              enddo
            endif
          endif
          endif ! calc_grad
c          t_eelecij=t_eelecij+MPI_Wtime()-time00
      return
      end
C-----------------------------------------------------------------------------
      subroutine eturn3(i,eello_turn3)
C Third- and fourth-order contributions from turns
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      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.CONTROL'
      include 'COMMON.SHIELD'
      include 'COMMON.CORRMAT'
      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),gpizda1(2,2),
     &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
     &  auxgmat2(2,2),auxgmatt2(2,2)
      double precision agg(3,4),aggi(3,4),aggi1(3,4),
     &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
     &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
     &    num_conti,j1,j2
      j=i+2
c      write (iout,*) "eturn3",i,j,j1,j2
      a_temp(1,1)=a22
      a_temp(1,2)=a23
      a_temp(2,1)=a32
      a_temp(2,2)=a33
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))
c auxalary matices for theta gradient
c auxalary matrix for i+1 and constant i+2
        call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
c auxalary matrix for i+2 and constant i+1
        call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
        call transpose2(auxmat(1,1),auxmat1(1,1))
        call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
        call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
        call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
        call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
        call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(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)
        if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
     &    eello_t3
        if (calc_grad) then
C#ifdef NEWCORR
C Derivatives in theta
        gloc(nphi+i,icg)=gloc(nphi+i,icg)
     &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
     &   *fac_shield(i)*fac_shield(j)
        gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
     &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
     &   *fac_shield(i)*fac_shield(j)
C#endif

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        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
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
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),auxmat3(1,1))
        call matmat2(a_temp(1,1),auxmat3(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),auxmat3(1,1))
        call matmat2(a_temp(1,1),auxmat3(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
c            ghalf1=0.5d0*agg(l,1)
c            ghalf2=0.5d0*agg(l,2)
c            ghalf3=0.5d0*agg(l,3)
c            ghalf4=0.5d0*agg(l,4)
          a_temp(1,1)=aggi(l,1)!+ghalf1
          a_temp(1,2)=aggi(l,2)!+ghalf2
          a_temp(2,1)=aggi(l,3)!+ghalf3
          a_temp(2,2)=aggi(l,4)!+ghalf4
          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)!+agg(l,1)
          a_temp(1,2)=aggi1(l,2)!+agg(l,2)
          a_temp(2,1)=aggi1(l,3)!+agg(l,3)
          a_temp(2,2)=aggi1(l,4)!+agg(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)!+ghalf1
          a_temp(1,2)=aggj(l,2)!+ghalf2
          a_temp(2,1)=aggj(l,3)!+ghalf3
          a_temp(2,2)=aggj(l,4)!+ghalf4
          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 ! calc_grad

      return
      end
C-------------------------------------------------------------------------------
      subroutine eturn4(i,eello_turn4)
C Third- and fourth-order contributions from turns
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      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.CONTROL'
      include 'COMMON.SHIELD'
      include 'COMMON.CORRMAT'
      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),auxgvec(2),
     &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
     &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
     &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
     &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
      double precision agg(3,4),aggi(3,4),aggi1(3,4),
     &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
     &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
     &    num_conti,j1,j2
      j=i+3
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)
c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
c        write(iout,*)"WCHODZE W PROGRAM"
        a_temp(1,1)=a22
        a_temp(1,2)=a23
        a_temp(2,1)=a32
        a_temp(2,2)=a33
        iti1=itype2loc(itype(i+1))
        iti2=itype2loc(itype(i+2))
        iti3=itype2loc(itype(i+3))
c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
        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))
C Ematrix derivative in theta
        call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
        call transpose2(gtEug(1,1,i+2),gte2t(1,1))
        call transpose2(gtEug(1,1,i+3),gte3t(1,1))
        call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
c       eta1 in derivative theta
        call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
        call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
c       auxgvec is derivative of Ub2 so i+3 theta
        call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1)) 
c       auxalary matrix of E i+1
        call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
c        s1=0.0
c        gs1=0.0    
        s1=scalar2(b1(1,i+2),auxvec(1))
c derivative of theta i+2 with constant i+3
        gs23=scalar2(gtb1(1,i+2),auxvec(1))
c derivative of theta i+2 with constant i+2
        gs32=scalar2(b1(1,i+2),auxgvec(1))
c derivative of E matix in theta of i+1
        gsE13=scalar2(b1(1,i+2),auxgEvec1(1))

        call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
c       ea31 in derivative theta
        call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
        call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1)) 
c auxilary matrix auxgvec of Ub2 with constant E matirx
        call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
c auxilary matrix auxgEvec1 of E matix with Ub2 constant
        call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))

c        s2=0.0
c        gs2=0.0
        s2=scalar2(b1(1,i+1),auxvec(1))
c derivative of theta i+1 with constant i+3
        gs13=scalar2(gtb1(1,i+1),auxvec(1))
c derivative of theta i+2 with constant i+1
        gs21=scalar2(b1(1,i+1),auxgvec(1))
c derivative of theta i+3 with constant i+1
        gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
c     &  gtb1(1,i+1)
        call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
c two derivatives over diffetent matrices
c gtae3e2 is derivative over i+3
        call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
c ae3gte2 is derivative over i+2
        call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
        call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
c three possible derivative over theta E matices
c i+1
        call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
c i+2
        call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
c i+3
        call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
        s3=0.5d0*(pizda(1,1)+pizda(2,2))

        gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
        gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
        gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(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.6
C        fac_shield(j)=0.4
        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)
c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
        if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
     &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
C Now derivative over shield:
          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
cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
cd     &    ' eello_turn4_num',8*eello_turn4_num
#ifdef NEWCORR
        gloc(nphi+i,icg)=gloc(nphi+i,icg)
     &                  -(gs13+gsE13+gsEE1)*wturn4
     &  *fac_shield(i)*fac_shield(j)
        gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
     &                    -(gs23+gs21+gsEE2)*wturn4
     &  *fac_shield(i)*fac_shield(j)

        gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
     &                    -(gs32+gsE31+gsEE3)*wturn4
     &  *fac_shield(i)*fac_shield(j)

c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
c     &   gs2
#endif
        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
     &      'eturn4',i,j,-(s1+s2+s3)
c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
c     &    ' eello_turn4_num',8*eello_turn4_num
C Derivatives in gamma(i)
        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,i+2),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,i+1),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,i+2),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,i+1),auxvec(1))
        call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
        call matmat2(auxmat3(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)
        if (calc_grad) then
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,i+2),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,i+1),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,i+2),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,i+1),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,i+2),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,i+1),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,i+2),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,i+1),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,i+2),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,i+1),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))
c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
          gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
     &  *fac_shield(i)*fac_shield(j)
        enddo

        endif ! calc_grad

      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 'DIMENSIONS.ZSCOPT'
      include 'COMMON.CONTROL'
      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))
        call to_box(xi,yi,zi)
        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
          call to_box(xj,yj,zj)
          xj=boxshift(xj-xi,boxxsize)
          yj=boxshift(yj-yi,boxysize)
          zj=boxshift(zj-zi,boxzsize)
          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,'(a6,2i5,0pf7.3,2i3,3e11.3)')
c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
c     &       bad(itypj,iteli)
          evdw2=evdw2+evdwij*sss
          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
     &       bad(itypj,iteli)

          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 ! calc_grad
        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 'DIMENSIONS.ZSCOPT'
      include 'COMMON.SBRIDGE'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.VAR'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTROL'
      include 'COMMON.IOUNITS'
      dimension ggg(3),ggg_peak(3,1000)
      ehpb=0.0D0
      do i=1,3
       ggg(i)=0.0d0
      enddo
c 8/21/18 AL: added explicit restraints on reference coords
c      write (iout,*) "restr_on_coord",restr_on_coord
      if (restr_on_coord) then

      do i=nnt,nct
        ecoor=0.0d0
        if (itype(i).eq.ntyp1) cycle
        do j=1,3
          ecoor=ecoor+(c(j,i)-cref(j,i))**2
          ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
        enddo
        if (itype(i).ne.10) then
          do j=1,3
            ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
            ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
          enddo
        endif
        if (energy_dec) write (iout,*) 
     &     "i",i," bfac",bfac(i)," ecoor",ecoor
        ehpb=ehpb+0.5d0*bfac(i)*ecoor
      enddo

      endif

C      write (iout,*) ,"link_end",link_end,constr_dist
cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
c     &  " constr_dist",constr_dist
      if (link_end.eq.0.and.link_end_peak.eq.0) return
      do i=link_start_peak,link_end_peak
        ehpb_peak=0.0d0
c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
c     &   ipeak(1,i),ipeak(2,i)
        do ip=ipeak(1,i),ipeak(2,i)
          ii=ihpb_peak(ip)
          jj=jhpb_peak(ip)
          dd=dist(ii,jj)
          iip=ip-ipeak(1,i)+1
C iii and jjj point to the residues for which the distance is assigned.
c          if (ii.gt.nres) then
c            iii=ii-nres
c            jjj=jj-nres 
c          else
c            iii=ii
c            jjj=jj
c          endif
          if (ii.gt.nres) then
            iii=ii-nres
          else
            iii=ii
          endif
          if (jj.gt.nres) then
            jjj=jj-nres
          else
            jjj=jj
          endif
          aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
          aux=dexp(-scal_peak*aux)
          ehpb_peak=ehpb_peak+aux
          fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
     &      forcon_peak(ip))*aux/dd
          do j=1,3
            ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
          enddo
          if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
     &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
     &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
        enddo
c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
        ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
        do ip=ipeak(1,i),ipeak(2,i)
          iip=ip-ipeak(1,i)+1
          do j=1,3
            ggg(j)=ggg_peak(j,iip)/ehpb_peak
          enddo
          ii=ihpb_peak(ip)
          jj=jhpb_peak(ip)
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
          if (iii.lt.ii) then
            do j=1,3
              ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
            enddo
          endif
          if (jjj.lt.jj) then
            do j=1,3
              ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
            enddo
          endif
          do k=1,3
            ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
            ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
          enddo
        enddo
      enddo
      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
        else
          iii=ii
        endif
        if (jj.gt.nres) then
          jjj=jj-nres
        else
          jjj=jj
        endif
c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
c     &    dhpb(i),dhpb1(i),forcon(i)
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
cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
        if (.not.dyn_ss .and. i.le.nss) then
C 15/02/13 CC dynamic SSbond - additional check
          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
cd          write (iout,*) "eij",eij
cd   &   ' waga=',waga,' fac=',fac
!        else if (ii.gt.nres .and. jj.gt.nres) then
        else 
C Calculate the distance between the two points and its difference from the
C target distance.
          dd=dist(ii,jj)
          if (irestr_type(i).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
            if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
     &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
     &        ehpb,irestr_type(i)
          else if (irestr_type(i).eq.10) then
c AL 6//19/2018 cross-link restraints
            xdis = 0.5d0*(dd/forcon(i))**2
            expdis = dexp(-xdis)
c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
            aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
c     &          " wboltzd",wboltzd
            ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
            fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
     &           *expdis/(aux*forcon(i)**2)
            if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)') 
     &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
     &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
          else if (irestr_type(i).eq.2) then
c Quartic restraints
            ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
            if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)') 
     &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
     &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
            fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
          else
c Quadratic restraints
            rdis=dd-dhpb(i)
C Get the force constant corresponding to this distance.
            waga=forcon(i)
C Calculate the contribution to energy.
            ehpb=ehpb+0.5d0*waga*rdis*rdis
            if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)') 
     &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
     &       0.5d0*waga*rdis*rdis,irestr_type(i)
C
C Evaluate gradient.
C
            fac=waga*rdis/dd
          endif
c Calculate Cartesian gradient
          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)
            enddo
          endif
          if (jjj.lt.jj) then
            do j=1,3
              ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
            enddo
          endif
          do k=1,3
            ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
            ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
          enddo
        endif
      enddo
      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 'DIMENSIONS.ZSCOPT'
      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 MODELLER restraint function
      subroutine e_modeller(ehomology_constr)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      include 'DIMENSIONS.FREE'
      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'
      include 'COMMON.HOMOLOGY'
      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 -------"
#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
         nexl=0
         do k=1,constr_homology
           if(.not.l_homo(k,ii)) then
              nexl=nexl+1
              cycle
           endif
           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)
         if (nexl.gt.0) then
           min_odl=0.0d0
         else
           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
         endif
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
#ifdef OLDRESTR
         odleg2=0.0d0
#else
         if (waga_dist.ge.0.0d0) then
           odleg2=nexl
         else
           odleg2=0.0d0
         endif
#endif
         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)
#ifdef OLD_DIHED
          kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
#else
          kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i)
#endif
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
#ifdef OLD_DIHED
          sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
#else
          sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)
#endif
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
#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
c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
        ehomology_constr=waga_dist*odleg+waga_angle*kat+
     &              waga_theta*Eval+waga_d*Erot
c     write (iout,*) "ehomology_constr=",ehomology_constr
      else
c
c          For Lorentzian-type Urestr
c  
c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
        ehomology_constr=-waga_dist*odleg+waga_angle*kat+
     &              waga_theta*Eval+waga_d*Erot
c     write (iout,*) "ehomology_constr=",ehomology_constr
      endif
#ifdef DEBUG
      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-----------------------------------------------------------------------
      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 'DIMENSIONS.ZSCOPT'
      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'
      double precision u(3),ud(3)
      estr=0.0d0
      estr1=0.0d0
c      write (iout,*) "distchainmax",distchainmax
      do i=nnt+1,nct
#ifdef FIVEDIAG
        if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
        diff = vbld(i)-vbldp0
#else
        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
C         write(iout,*) i,diff
         else
          diff = vbld(i)-vbldp0
c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
         endif
#endif
          estr=estr+diff*diff
          do j=1,3
            gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
          enddo
C        endif
          if (energy_dec) write (iout,'(a7,i5,4f7.3)')
     &     "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)
            if (energy_dec) write (iout,*) "estr sc",iti,vbld(i+nres),
     &      vbldsc0(1,iti),diff,
     &      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 'DIMENSIONS.ZSCOPT'
      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
        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(i-3).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,'(a6,i5,0pf7.3,f7.3,i5)')
c     &      'ebend',i,ethetai,theta(i),itype(i)
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
      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
C Ufff.... We've done all this!!! 
      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)
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 'DIMENSIONS.ZSCOPT'
      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        if (itype(i-1).eq.ntyp1) cycle
        if (i.le.2) cycle
        if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
     &  .or.itype(i).eq.ntyp1) cycle
        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
cu        if (i.eq.3) then 
cu          phii=0.0d0
cu          ityp1=nthetyp+1
cu          do k=1,nsingle
cu            cosph1(k)=0.0d0
cu            sinph1(k)=0.0d0
cu          enddo
cu        else
        if (i.gt.3 .and. itype(i-3).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
c          ityp1=nthetyp+1
          do k=1,nsingle
            ityp1=ithetyp((itype(i-2)))
            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
c          ityp3=nthetyp+1
          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
      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 'DIMENSIONS.ZSCOPT'
      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,*) '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)
          write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
     &             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,*) 'i=',i, escloci
        else
          call enesc(x,escloci,dersc,ddummy,.false.)
        endif

        escloc=escloc+escloci
C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
            write (iout,'(a6,i5,0pf7.3)')
     &     'escloc',i,escloci

        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 'DIMENSIONS.ZSCOPT'
      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))
        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
c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
c     &  zz,xx,yy
        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 'DIMENSIONS.ZSCOPT'
      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,fact)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      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
      return
      end
c------------------------------------------------------------------------------
#else
      subroutine etor(etors,fact)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      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
C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
C     &       .or. itype(i).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
c          if (energy_dec) etors_ii=etors_ii+
c     &                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
      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 'DIMENSIONS.ZSCOPT'
      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
C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) 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---------------------------------------------------------------------------
C The rigorous attempt to derive energy function
      subroutine etor_kcc(etors,fact)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      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'
      include 'COMMON.CONTROL'
      double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
      logical lprn
c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
C Set lprn=.true. for debugging
      lprn=energy_dec
c     lprn=.true.
C      print *,"wchodze kcc"
      if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
      etors=0.0D0
      do i=iphi_start,iphi_end
C ANY TWO ARE DUMMY ATOMS in row CYCLE
c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) 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
        itori=itortyp(itype(i-2))
        itori1=itortyp(itype(i-1))
        phii=phi(i)
        glocig=0.0D0
        glocit1=0.0d0
        glocit2=0.0d0
C to avoid multiple devision by 2
c        theti22=0.5d0*theta(i)
C theta 12 is the theta_1 /2
C theta 22 is theta_2 /2
c        theti12=0.5d0*theta(i-1)
C and appropriate sinus function
        sinthet1=dsin(theta(i-1))
        sinthet2=dsin(theta(i))
        costhet1=dcos(theta(i-1))
        costhet2=dcos(theta(i))
C to speed up lets store its mutliplication
        sint1t2=sinthet2*sinthet1        
        sint1t2n=1.0d0
C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
C +d_n*sin(n*gamma)) *
C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2))) 
C we have two sum 1) Non-Chebyshev which is with n and gamma
        nval=nterm_kcc_Tb(itori,itori1)
        c1(0)=0.0d0
        c2(0)=0.0d0
        c1(1)=1.0d0
        c2(1)=1.0d0
        do j=2,nval
          c1(j)=c1(j-1)*costhet1
          c2(j)=c2(j-1)*costhet2
        enddo
        etori=0.0d0
        do j=1,nterm_kcc(itori,itori1)
          cosphi=dcos(j*phii)
          sinphi=dsin(j*phii)
          sint1t2n1=sint1t2n
          sint1t2n=sint1t2n*sint1t2
          sumvalc=0.0d0
          gradvalct1=0.0d0
          gradvalct2=0.0d0
          do k=1,nval
            do l=1,nval
              sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
              gradvalct1=gradvalct1+
     &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
              gradvalct2=gradvalct2+
     &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
            enddo
          enddo
          gradvalct1=-gradvalct1*sinthet1
          gradvalct2=-gradvalct2*sinthet2
          sumvals=0.0d0
          gradvalst1=0.0d0
          gradvalst2=0.0d0 
          do k=1,nval
            do l=1,nval
              sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
              gradvalst1=gradvalst1+
     &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
              gradvalst2=gradvalst2+
     &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
            enddo
          enddo
          gradvalst1=-gradvalst1*sinthet1
          gradvalst2=-gradvalst2*sinthet2
          etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
C glocig is the gradient local i site in gamma
          glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
C now gradient over theta_1
          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
     &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
     &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
        enddo ! j
        etors=etors+etori
C derivative over gamma
        gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
C derivative over theta1
        gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
C now derivative over theta2
        gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
        if (lprn) then
          write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
     &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
          write (iout,*) "c1",(c1(k),k=0,nval),
     &    " c2",(c2(k),k=0,nval)
          write (iout,*) "sumvalc",sumvalc," sumvals",sumvals
        endif
      enddo
      return
      end
c---------------------------------------------------------------------------------------------
      subroutine etor_constr(edihcnstr)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      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'
      include 'COMMON.CONTROL'
! 6/20/98 - dihedral angle constraints
      edihcnstr=0.0d0
c      do i=1,ndih_constr
c      write (iout,*) "idihconstr_start",idihconstr_start,
c     &  " idihconstr_end",idihconstr_end

      if (raw_psipred) then
        do i=idihconstr_start,idihconstr_end
          itori=idih_constr(i)
          phii=phi(itori)
          gaudih_i=vpsipred(1,i)
          gauder_i=0.0d0
          do j=1,2
            s = sdihed(j,i)
            cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
            dexpcos_i=dexp(-cos_i*cos_i)
            gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
            gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
     &            *cos_i*dexpcos_i/s**2
          enddo
          edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
          gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
          if (energy_dec)
     &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
     &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
     &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
     &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
     &     -wdihc*dlog(gaudih_i)
        enddo
      else

      do i=idihconstr_start,idihconstr_end
        itori=idih_constr(i)
        phii=phi(itori)
        difi=pinorm(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
        else
          difi=0.0
        endif
      enddo

      endif

c      write (iout,*) "ETOR_CONSTR",edihcnstr
      return
      end
c----------------------------------------------------------------------------
C The rigorous attempt to derive energy function
      subroutine ebend_kcc(etheta)

      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      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'
      include 'COMMON.CONTROL'
      logical lprn
      double precision thybt1(maxang_kcc)
C Set lprn=.true. for debugging
      lprn=energy_dec
c     lprn=.true.
C      print *,"wchodze kcc"
      if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
      etheta=0.0D0
      do i=ithet_start,ithet_end
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
        iti=iabs(itortyp(itype(i-1)))
        sinthet=dsin(theta(i))
        costhet=dcos(theta(i))
        do j=1,nbend_kcc_Tb(iti)
          thybt1(j)=v1bend_chyb(j,iti)
        enddo
        sumth1thyb=v1bend_chyb(0,iti)+
     &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
        if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
     &    sumth1thyb
        ihelp=nbend_kcc_Tb(iti)-1
        gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
        etheta=etheta+sumth1thyb
C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
        gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
      enddo
      return
      end
c-------------------------------------------------------------------------------------
      subroutine etheta_constr(ethetacnstr)

      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      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'
      include 'COMMON.CONTROL'
      ethetacnstr=0.0d0
C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
      do i=ithetaconstr_start,ithetaconstr_end
        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
       if (energy_dec) then
        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
     &    i,itheta,rad2deg*thetiii,
     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
     &    gloc(itheta+nphi-2,icg)
        endif
      enddo
      return
      end
c------------------------------------------------------------------------------
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 'DIMENSIONS.ZSCOPT'
      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
           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
         enddo
C      write (iout,*)"EBACK_SC_COR",esccor,i
c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
c     & nterm_sccor(isccori,isccori1),isccori,isccori1
c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+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)
c        gsccor_loc(i-3)=gloci
       enddo !intertyp
      enddo
      return
      end
#ifdef FOURBODY
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'
      include 'COMMON.CONTMAT'
      include 'COMMON.CORRMAT'
      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'
      include 'COMMON.CONTMAT'
      include 'COMMON.CORRMAT'
      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------------------------------------------------------------------------------
      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 'DIMENSIONS.ZSCOPT'
      include 'COMMON.IOUNITS'
      include 'COMMON.FFIELD'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
      include 'COMMON.CORRMAT'
      double precision gx(3),gx1(3)
      logical lprn,ldone

C Set lprn=.true. for debugging
      lprn=.false.
      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 'DIMENSIONS.ZSCOPT'
      include 'COMMON.IOUNITS'
#ifdef MPI
      include "mpif.h"
#endif
      include 'COMMON.FFIELD'
      include 'COMMON.DERIV'
      include 'COMMON.LOCAL'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
      include 'COMMON.CORRMAT'
      include 'COMMON.CHAIN'
      include 'COMMON.CONTROL'
      include 'COMMON.SHIELD'
      double precision gx(3),gx1(3)
      integer num_cont_hb_old(maxres)
      logical lprn,ldone
      double precision eello4,eello5,eelo6,eello_turn6
      external eello4,eello5,eello6,eello_turn6
C Set lprn=.true. for debugging
      lprn=.false.
      eturn6=0.0d0
      if (lprn) then
        write (iout,'(a)') 'Contact function values:'
        do i=nnt,nct-2
          write (iout,'(2i3,50(1x,i2,5f6.3))') 
     &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
     &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),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)
#ifdef MOMENT
          call dipole(i,j,jj)
#endif
        enddo
      enddo
      endif
C Calculate the local-electrostatic correlation terms
c                write (iout,*) "gradcorr5 in eello5 before loop"
c                do iii=1,nres
c                  write (iout,'(i5,3f10.5)') 
c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
c                enddo
      do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
c        write (iout,*) "corr loop i",i
        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)
          jp=iabs(j)
          do kk=1,num_conti1
            j1=jcont_hb(kk,i1)
            jp1=iabs(j1)
c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
c     &         ' jj=',jj,' kk=',kk
c            if (j1.eq.j+1 .or. j1.eq.j-1) then
            if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 
     &          .or. j.lt.0 .and. j1.gt.0) .and.
     &         (jp1.eq.jp+1 .or. jp1.eq.jp-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)
cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
cd     &         ' 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,
cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
cd               write (iout,*) "g_contij",g_contij
cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
                call calc_eello(i,jp,i+1,jp1,jj,kk)
                if (wcorr4.gt.0.0d0) 
     &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
CC     &            *fac_shield(i)**2*fac_shield(j)**2
                  if (energy_dec.and.wcorr4.gt.0.0d0) 
     1                 write (iout,'(a6,4i5,0pf7.3)')
     2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
c                write (iout,*) "gradcorr5 before eello5"
c                do iii=1,nres
c                  write (iout,'(i5,3f10.5)') 
c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
c                enddo
                if (wcorr5.gt.0.0d0)
     &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
c                write (iout,*) "gradcorr5 after eello5"
c                do iii=1,nres
c                  write (iout,'(i5,3f10.5)') 
c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
c                enddo
                  if (energy_dec.and.wcorr5.gt.0.0d0) 
     1                 write (iout,'(a6,4i5,0pf7.3)')
     2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
cd                write(2,*)'ijkl',i,jp,i+1,jp1 
                if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.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,jp,i+1,jp1,jj,kk)
                  if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
     1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
cd     &            'ecorr6=',ecorr6
cd                write (iout,'(4e15.5)') sred_geom,
cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
                else if (wturn6.gt.0.0d0
     &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
                  eturn6=eturn6+eello_turn6(i,jj,kk)
                  if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
     1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
cd                  write (2,*) 'multibody_eello:eturn6',eturn6
                endif
              ENDIF
1111          continue
            endif
          enddo ! kk
        enddo ! jj
      enddo ! i
      do i=1,nres
        num_cont_hb(i)=num_cont_hb_old(i)
      enddo
c                write (iout,*) "gradcorr5 in eello5"
c                do iii=1,nres
c                  write (iout,'(i5,3f10.5)') 
c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
c                enddo
      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 'DIMENSIONS.ZSCOPT'
      include 'COMMON.IOUNITS'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
      include 'COMMON.CORRMAT'
      include 'COMMON.SHIELD'
      include 'COMMON.CONTROL'
      double precision gx(3),gx1(3)
      logical lprn
      lprn=.false.
C      print *,"wchodze",fac_shield(i),shield_mode
      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)
C*
C     & fac_shield(i)**2*fac_shield(j)**2
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,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
c     & 'Contacts ',i,j,
c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
c     & 'gradcorr_long'
C Calculate the multi-body contribution to energy.
C      ecorr=ecorr+ekont*ees
C Calculate multi-body contributions to the gradient.
      coeffpees0pij=coeffp*ees0pij
      coeffmees0mij=coeffm*ees0mij
      coeffpees0pkl=coeffp*ees0pkl
      coeffmees0mkl=coeffm*ees0mkl
      do ll=1,3
cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
        gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
     &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
     &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
        gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
     &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
     &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
        gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
     &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
     &  coeffmees0mij*gacontm_hb1(ll,kk,k))
        gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
     &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
     &  coeffmees0mij*gacontm_hb2(ll,kk,k))
        gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
     &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
     &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
        gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
        gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
        gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
     &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
     &     coeffmees0mij*gacontm_hb3(ll,kk,k))
        gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
        gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
      enddo
c      write (iout,*)
cgrad      do m=i+1,j-1
cgrad        do ll=1,3
cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
cgrad        enddo
cgrad      enddo
cgrad      do m=k+1,l-1
cgrad        do ll=1,3
cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
cgrad        enddo
cgrad      enddo 
c      write (iout,*) "ehbcorr",ekont*ees
C      print *,ekont,ees,i,k
      ehbcorr=ekont*ees
C now gradient over shielding
C      return
      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
      return
      end
#ifdef MOMENT
C---------------------------------------------------------------------------
      subroutine dipole(i,j,jj)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.FFIELD'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
      include 'COMMON.CORRMAT'
      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
        itj1 = itype2loc(itype(j+1))
      else
        itj1=nloctyp
      endif
      do iii=1,2
        dipi(iii,1)=Ub2(iii,i)
        dipderi(iii)=Ub2der(iii,i)
        dipi(iii,2)=b1(iii,i+1)
        dipj(iii,1)=Ub2(iii,j)
        dipderj(iii)=Ub2der(iii,j)
        dipj(iii,2)=b1(iii,j+1)
      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
      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
#endif
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 'DIMENSIONS.ZSCOPT'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
      include 'COMMON.CORRMAT'
      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
cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
      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.
        if (i.gt.1) then
          iti=itype2loc(itype(i))
        else
          iti=nloctyp
        endif
        itk1=itype2loc(itype(k+1))
        itj=itype2loc(itype(j))
        if (l.lt.nres-1) then
          itl1=itype2loc(itype(l+1))
        else
          itl1=nloctyp
        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,i),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,i),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,k+1),AEAb1(1,2,1))
        call matvec2(AEAderg(1,1,1),b1(1,k+1),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,j),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,j),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,l+1),AEAb1(1,2,2))
        call matvec2(AEAderg(1,1,2),b1(1,l+1),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,i),
     &          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,k+1),
     &          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,j),
     &          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,l+1),
     &          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.
        if (i.gt.1) then
          iti=itype2loc(itype(i))
        else
          iti=nloctyp
        endif
        itk1=itype2loc(itype(k+1))
        itl=itype2loc(itype(l))
        itj=itype2loc(itype(j))
        if (j.lt.nres-1) then
          itj1=itype2loc(itype(j+1))
        else 
          itj1=nloctyp
        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,i),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,i),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,k+1),AEAb1(1,2,1))
        call matvec2(AEAderg(1,1,1),b1(1,k+1),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,j+1),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,l),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,j+1),AEAb1(1,2,2))
        call matvec2(AEAderg(1,1,2),b1(1,j+1),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,i),
     &          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,k+1),
     &          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,l),
     &          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,j+1),
     &          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 'DIMENSIONS.ZSCOPT'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
      include 'COMMON.CORRMAT'
      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
cgrad        ggg1(ll)=eel4*g_contij(ll,1)
cgrad        ggg2(ll)=eel4*g_contij(ll,2)
        glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
        glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
cgrad        ghalf=0.5d0*ggg1(ll)
        gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
        gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
        gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
        gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
        gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
        gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
cgrad        ghalf=0.5d0*ggg2(ll)
        gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
        gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
        gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
        gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
        gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
        gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
      enddo
cgrad      do m=i+1,j-1
cgrad        do ll=1,3
cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
cgrad        enddo
cgrad      enddo
cgrad      do m=k+1,l-1
cgrad        do ll=1,3
cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
cgrad        enddo
cgrad      enddo
cgrad      do m=i+2,j2
cgrad        do ll=1,3
cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
cgrad        enddo
cgrad      enddo
cgrad      do m=k+2,l2
cgrad        do ll=1,3
cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
cgrad        enddo
cgrad      enddo 
cd      do iii=1,nres-3
cd        write (2,*) iii,gcorr_loc(iii)
cd      enddo
      endif ! calc_grad
      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 'DIMENSIONS.ZSCOPT'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
      include 'COMMON.CORRMAT'
      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=itype2loc(itype(k))
      itl=itype2loc(itype(l))
      itj=itype2loc(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
      endif ! calc_grad 
c      goto 1112
c1111  continue
C Contribution from graph II 
      call transpose2(EE(1,1,k),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,k))
     & -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,k))
     &   -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,k))
     &   -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,k))
     &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
          enddo
        enddo
      enddo
      endif ! calc_grad
cd      goto 1112
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
C Contribution from graph IV
cd1110    continue
        call transpose2(EE(1,1,l),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,l))
     &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
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,l))
     &   -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,l))
     &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
            enddo
          enddo
        enddo
        endif ! calc_grad
      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
        endif ! calc_grad
cd        goto 1112
C Contribution from graph IV
1110    continue
        call transpose2(EE(1,1,j),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,j))
     &   -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,j))
     &   -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,j))
     &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
            enddo
          enddo
        enddo
        endif ! calc_grad
      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
C 2/11/08 AL Gradients over DC's connecting interacting sites will be
C        summed up outside the subrouine as for the other subroutines 
C        handling long-range interactions. The old code is commented out
C        with "cgrad" to keep track of changes.
      do ll=1,3
cgrad        ggg1(ll)=eel5*g_contij(ll,1)
cgrad        ggg2(ll)=eel5*g_contij(ll,2)
        gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
        gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') 
c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') 
c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
c     &   gradcorr5ij,
c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
cgrad        ghalf=0.5d0*ggg1(ll)
cd        ghalf=0.0d0
        gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
        gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
        gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
        gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
        gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
        gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
cgrad        ghalf=0.5d0*ggg2(ll)
cd        ghalf=0.0d0
        gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
        gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
        gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
        gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
        gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
        gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
      enddo
      endif ! calc_grad
cd      goto 1112
cgrad      do m=i+1,j-1
cgrad        do ll=1,3
cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
cgrad        enddo
cgrad      enddo
cgrad      do m=k+1,l-1
cgrad        do ll=1,3
cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
cgrad        enddo
cgrad      enddo
c1112  continue
cgrad      do m=i+2,j2
cgrad        do ll=1,3
cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
cgrad        enddo
cgrad      enddo
cgrad      do m=k+2,l2
cgrad        do ll=1,3
cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
cgrad        enddo
cgrad      enddo 
cd      do iii=1,nres-3
cd        write (2,*) iii,g_corr5_loc(iii)
cd      enddo
      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 'DIMENSIONS.ZSCOPT'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
      include 'COMMON.CORRMAT'
      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
cgrad        ggg1(ll)=eel6*g_contij(ll,1)
cgrad        ggg2(ll)=eel6*g_contij(ll,2)
cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
cgrad        ghalf=0.5d0*ggg1(ll)
cd        ghalf=0.0d0
        gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
        gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
        gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
        gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
        gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
        gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
        gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
        gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
cgrad        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)+ekont*derx(ll,2,2)
        gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
        gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
        gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
        gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
        gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
      enddo
      endif ! calc_grad
cd      goto 1112
cgrad      do m=i+1,j-1
cgrad        do ll=1,3
cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
cgrad        enddo
cgrad      enddo
cgrad      do m=k+1,l-1
cgrad        do ll=1,3
cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
cgrad        enddo
cgrad      enddo
cgrad1112  continue
cgrad      do m=i+2,j2
cgrad        do ll=1,3
cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
cgrad        enddo
cgrad      enddo
cgrad      do m=k+2,l2
cgrad        do ll=1,3
cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
cgrad        enddo
cgrad      enddo 
cd      do iii=1,nres-3
cd        write (2,*) iii,g_corr6_loc(iii)
cd      enddo
      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 'DIMENSIONS.ZSCOPT'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
      include 'COMMON.CORRMAT'
      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=itype2loc(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,k)-AEAb1(2,2,imat)*b1(2,k)
      vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
      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 (calc_grad) then
      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,k)-AEAb1derg(2,2,imat)*b1(2,k)
      vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
      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,k)
     &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
            vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
     &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
            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
      endif ! calc_grad
      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 'DIMENSIONS.ZSCOPT'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
      include 'COMMON.CORRMAT'
      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
C Derivatives in gamma(i-1)
      if (calc_grad) then
      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
      endif ! calc_grad
      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 'DIMENSIONS.ZSCOPT'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
      include 'COMMON.CORRMAT'
      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))
      if (j.lt.nres-1) then
        itj1=itype2loc(itype(j+1))
      else
        itj1=nloctyp
      endif
      itk=itype2loc(itype(k))
      itk1=itype2loc(itype(k+1))
      if (l.lt.nres-1) then
        itl1=itype2loc(itype(l+1))
      else
        itl1=nloctyp
      endif
#ifdef MOMENT
      s1=dip(4,jj,i)*dip(4,kk,k)
#endif
      call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
      s2=0.5d0*scalar2(b1(1,k),auxvec(1))
      call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
      s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
      call transpose2(EE(1,1,k),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,
cd     & "sum",-(s2+s3+s4)
#ifdef MOMENT
      eello6_graph3=-(s1+s2+s3+s4)
#else
      eello6_graph3=-(s2+s3+s4)
#endif
c      eello6_graph3=-s4
C Derivatives in gamma(k-1)
      if (calc_grad) then
      call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
      s3=0.5d0*scalar2(b1(1,j+1),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,k+1),auxvec(1))
      s2=0.5d0*scalar2(b1(1,k),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,k+1),
     &        auxvec(1))
            s2=0.5d0*scalar2(b1(1,k),auxvec(1))
            call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
     &        auxvec(1))
            s3=0.5d0*scalar2(b1(1,j+1),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
      endif ! calc_grad
      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 'DIMENSIONS.ZSCOPT'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
      include 'COMMON.CORRMAT'
      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=itype2loc(itype(i))
      itj=itype2loc(itype(j))
      if (j.lt.nres-1) then
        itj1=itype2loc(itype(j+1))
      else
        itj1=nloctyp
      endif
      itk=itype2loc(itype(k))
      if (k.lt.nres-1) then
        itk1=itype2loc(itype(k+1))
      else
        itk1=nloctyp
      endif
      itl=itype2loc(itype(l))
      if (l.lt.nres-1) then
        itl1=itype2loc(itype(l+1))
      else
        itl1=nloctyp
      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,j+1),auxvec1(1))
        s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
      else
        call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
        s3=-0.5d0*scalar2(b1(1,l),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
C Derivatives in gamma(i-1)
      if (calc_grad) then
      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,j+1),auxvec1(1))
          s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
        else
          call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
          s3=-0.5d0*scalar2(b1(1,l),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,j+1),auxvec1(1))
        s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
      else
        call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
        s3=-0.5d0*scalar2(b1(1,l),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,j+1),auxvec(1))
              s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
            else
              call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
     &          b1(1,l+1),auxvec(1))
              s3=-0.5d0*scalar2(b1(1,l),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
      endif ! calc_grad
      return
      end
c----------------------------------------------------------------------------
      double precision function eello_turn6(i,jj,kk)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      include 'COMMON.IOUNITS'
      include 'COMMON.CHAIN'
      include 'COMMON.DERIV'
      include 'COMMON.INTERACT'
      include 'COMMON.CONTACTS'
      include 'COMMON.CONTMAT'
      include 'COMMON.CORRMAT'
      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.
      s1=0.0d0
      s8=0.0d0
      s13=0.0d0
c
      eello_turn6=0.0d0
      j=i+4
      k=i+1
      l=i+3
      iti=itype2loc(itype(i))
      itk=itype2loc(itype(k))
      itk1=itype2loc(itype(k+1))
      itl=itype2loc(itype(l))
      itj=itype2loc(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,l))
      s1 = (auxmat(1,1)+auxmat(2,2))*ss1
#endif
      call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
      call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
      s2 = scalar2(b1(1,k),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,k+1),vtemp2(1))
      s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
#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,k),vtemp4(1))
      s13 = (gtemp(1,1)+gtemp(2,2))*ss13
#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)
C Derivatives in gamma(i+2)
      if (calc_grad) then
      s1d =0.0d0
      s8d =0.0d0
#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,l),vtemp2(1))
#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,l))
      s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
#endif
      call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
      call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
      s2d = scalar2(b1(1,k),vtemp1d(1))
#ifdef MOMENT
      call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
      s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),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
#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
#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
#endif
      call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
      call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
      s2d = scalar2(b1(1,k),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,l),vtemp2(1))
#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,k),vtemp4d(1))
      s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
#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
#endif
            call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
            call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
     &          vtemp1d(1))
            s2d = scalar2(b1(1,k),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,l),vtemp2(1))
#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,k),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
cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
cgrad        ghalf=0.5d0*ggg1(ll)
cd        ghalf=0.0d0
        gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
        gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
        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)
        gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
        gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
cgrad        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)
        gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
        gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
      enddo
cd      goto 1112
cgrad      do m=i+1,j-1
cgrad        do ll=1,3
cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
cgrad        enddo
cgrad      enddo
cgrad      do m=k+1,l-1
cgrad        do ll=1,3
cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
cgrad        enddo
cgrad      enddo
cgrad1112  continue
cgrad      do m=i+2,j2
cgrad        do ll=1,3
cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
cgrad        enddo
cgrad      enddo
cgrad      do m=k+2,l2
cgrad        do ll=1,3
cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
cgrad        enddo
cgrad      enddo 
cd      do iii=1,nres-3
cd        write (2,*) iii,g_corr6_loc(iii)
cd      enddo
      endif ! calc_grad
      eello_turn6=ekont*eel_turn6
cd      write (2,*) 'ekont',ekont
cd      write (2,*) 'eel_turn6',ekont*eel_turn6
      return
      end
#endif
crc-------------------------------------------------
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      subroutine Eliptransfer(eliptran)
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      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
      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


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      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-----------------------------------------------------------------------
      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-----------------------------------------------------------------------
       subroutine set_shield_fac
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      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 first for shielding is setting of function of side-chains
       subroutine set_shield_fac2
      implicit real*8 (a-h,o-z)
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      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),
c     &  " wshield",wshield
c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
      enddo
      return
      end
C--------------------------------------------------------------------------
      double precision function tschebyshev(m,n,x,y)
      implicit none
      include "DIMENSIONS"
      integer i,m,n
      double precision x(n),y,yy(0:maxvar),aux
c Tschebyshev polynomial. Note that the first term is omitted
c m=0: the constant term is included
c m=1: the constant term is not included
      yy(0)=1.0d0
      yy(1)=y
      do i=2,n
        yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
      enddo
      aux=0.0d0
      do i=m,n
        aux=aux+x(i)*yy(i)
      enddo
      tschebyshev=aux
      return
      end
C--------------------------------------------------------------------------
      double precision function gradtschebyshev(m,n,x,y)
      implicit none
      include "DIMENSIONS"
      integer i,m,n
      double precision x(n+1),y,yy(0:maxvar),aux
c Tschebyshev polynomial. Note that the first term is omitted
c m=0: the constant term is included
c m=1: the constant term is not included
      yy(0)=1.0d0
      yy(1)=2.0d0*y
      do i=2,n
        yy(i)=2*y*yy(i-1)-yy(i-2)
      enddo
      aux=0.0d0
      do i=m,n
        aux=aux+x(i+1)*yy(i)*(i+1)
C        print *, x(i+1),yy(i),i
      enddo
      gradtschebyshev=aux
      return
      end
c----------------------------------------------------------------------------
      double precision function sscale2(r,r_cut,r0,rlamb)
      implicit none
      double precision r,gamm,r_cut,r0,rlamb,rr
      rr = dabs(r-r0)
c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
c      write (2,*) "rr",rr
      if(rr.lt.r_cut-rlamb) then
        sscale2=1.0d0
      else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
        gamm=(rr-(r_cut-rlamb))/rlamb
        sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
      else
        sscale2=0d0
      endif
      return
      end
C-----------------------------------------------------------------------
      double precision function sscalgrad2(r,r_cut,r0,rlamb)
      implicit none
      double precision r,gamm,r_cut,r0,rlamb,rr
      rr = dabs(r-r0)
      if(rr.lt.r_cut-rlamb) then
        sscalgrad2=0.0d0
      else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
        gamm=(rr-(r_cut-rlamb))/rlamb
        if (r.ge.r0) then
          sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
        else
          sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
        endif
      else
        sscalgrad2=0.0d0
      endif
      return
      end
c----------------------------------------------------------------------------
      subroutine e_saxs(Esaxs_constr)
      implicit none
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      include 'DIMENSIONS.FREE'
#ifdef MPI
      include "mpif.h"
      include "COMMON.SETUP"
      integer IERR
#endif
      include 'COMMON.SBRIDGE'
      include 'COMMON.CHAIN'
      include 'COMMON.GEO'
      include 'COMMON.LOCAL'
      include 'COMMON.INTERACT'
      include 'COMMON.VAR'
      include 'COMMON.IOUNITS'
      include 'COMMON.DERIV'
      include 'COMMON.CONTROL'
      include 'COMMON.NAMES'
      include 'COMMON.FFIELD'
      include 'COMMON.LANGEVIN'
      include 'COMMON.SAXS'
c
      double precision Esaxs_constr
      integer i,iint,j,k,l
      double precision PgradC(maxSAXS,3,maxres),
     &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
#ifdef MPI
      double precision PgradC_(maxSAXS,3,maxres),
     &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
#endif
      double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
     & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
     & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
     & auxX,auxX1,CACAgrad,Cnorm
      double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
      double precision dist
      external dist
c  SAXS restraint penalty function
#ifdef DEBUG
      write(iout,*) "------- SAXS penalty function start -------"
      write (iout,*) "nsaxs",nsaxs
      write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
      write (iout,*) "Psaxs"
      do i=1,nsaxs
        write (iout,'(i5,e15.5)') i, Psaxs(i)
      enddo
#endif
      Esaxs_constr = 0.0d0
      do k=1,nsaxs
        Pcalc(k)=0.0d0
        do j=1,nres
          do l=1,3
            PgradC(k,l,j)=0.0d0
            PgradX(k,l,j)=0.0d0
          enddo
        enddo
      enddo
      do i=iatsc_s,iatsc_e
       if (itype(i).eq.ntyp1) cycle
       do iint=1,nint_gr(i)
         do j=istart(i,iint),iend(i,iint)
           if (itype(j).eq.ntyp1) cycle
#ifdef ALLSAXS
           dijCACA=dist(i,j)
           dijCASC=dist(i,j+nres)
           dijSCCA=dist(i+nres,j)
           dijSCSC=dist(i+nres,j+nres)
           sigma2CACA=2.0d0/(pstok**2)
           sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
           sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
           sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
           do k=1,nsaxs
             dk = distsaxs(k)
             expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
             if (itype(j).ne.10) then
             expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
             else
             endif
             expCASC = 0.0d0
             if (itype(i).ne.10) then
             expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
             else 
             expSCCA = 0.0d0
             endif
             if (itype(i).ne.10 .and. itype(j).ne.10) then
             expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
             else
             expSCSC = 0.0d0
             endif
             Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
#ifdef DEBUG
             write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
#endif
             CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
             CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
             SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
             SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
             do l=1,3
c CA CA 
               aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
               PgradC(k,l,i) = PgradC(k,l,i)-aux
               PgradC(k,l,j) = PgradC(k,l,j)+aux
c CA SC
               if (itype(j).ne.10) then
               aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
               PgradC(k,l,i) = PgradC(k,l,i)-aux
               PgradC(k,l,j) = PgradC(k,l,j)+aux
               PgradX(k,l,j) = PgradX(k,l,j)+aux
               endif
c SC CA
               if (itype(i).ne.10) then
               aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
               PgradX(k,l,i) = PgradX(k,l,i)-aux
               PgradC(k,l,i) = PgradC(k,l,i)-aux
               PgradC(k,l,j) = PgradC(k,l,j)+aux
               endif
c SC SC
               if (itype(i).ne.10 .and. itype(j).ne.10) then
               aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
               PgradC(k,l,i) = PgradC(k,l,i)-aux
               PgradC(k,l,j) = PgradC(k,l,j)+aux
               PgradX(k,l,i) = PgradX(k,l,i)-aux
               PgradX(k,l,j) = PgradX(k,l,j)+aux
               endif
             enddo ! l
           enddo ! k
#else
           dijCACA=dist(i,j)
           sigma2CACA=scal_rad**2*0.25d0/
     &        (restok(itype(j))**2+restok(itype(i))**2)

           IF (saxs_cutoff.eq.0) THEN
           do k=1,nsaxs
             dk = distsaxs(k)
             expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
             Pcalc(k) = Pcalc(k)+expCACA
             CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
             do l=1,3
               aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
               PgradC(k,l,i) = PgradC(k,l,i)-aux
               PgradC(k,l,j) = PgradC(k,l,j)+aux
             enddo ! l
           enddo ! k
           ELSE
           rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
           do k=1,nsaxs
             dk = distsaxs(k)
c             write (2,*) "ijk",i,j,k
             sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
             if (sss2.eq.0.0d0) cycle
             ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
             expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
             Pcalc(k) = Pcalc(k)+expCACA
#ifdef DEBUG
             write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
#endif
             CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
     &             ssgrad2*expCACA/sss2
             do l=1,3
c CA CA 
               aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
               PgradC(k,l,i) = PgradC(k,l,i)+aux
               PgradC(k,l,j) = PgradC(k,l,j)-aux
             enddo ! l
           enddo ! k
           ENDIF
#endif
         enddo ! j
       enddo ! iint
      enddo ! i
#ifdef MPI
      if (nfgtasks.gt.1) then 
        call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
     &    MPI_SUM,king,FG_COMM,IERR)
        if (fg_rank.eq.king) then
          do k=1,nsaxs
            Pcalc(k) = Pcalc_(k)
          enddo
        endif
        call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
     &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
        if (fg_rank.eq.king) then
          do i=1,nres
            do l=1,3
              do k=1,nsaxs
                PgradC(k,l,i) = PgradC_(k,l,i)
              enddo
            enddo
          enddo
        endif
#ifdef ALLSAXS
        call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
     &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
        if (fg_rank.eq.king) then
          do i=1,nres
            do l=1,3
              do k=1,nsaxs
                PgradX(k,l,i) = PgradX_(k,l,i)
              enddo
            enddo
          enddo
        endif
#endif
      endif
#endif
#ifdef MPI
      if (fg_rank.eq.king) then
#endif
      Cnorm = 0.0d0
      do k=1,nsaxs
        Cnorm = Cnorm + Pcalc(k)
      enddo
      Esaxs_constr = dlog(Cnorm)-wsaxs0
      do k=1,nsaxs
        if (Pcalc(k).gt.0.0d0) 
     &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k)) 
#ifdef DEBUG
        write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
#endif
      enddo
#ifdef DEBUG
      write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
#endif
      do i=nnt,nct
        do l=1,3
          auxC=0.0d0
          auxC1=0.0d0
          auxX=0.0d0
          auxX1=0.d0 
          do k=1,nsaxs
            if (Pcalc(k).gt.0) 
     &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
            auxC1 = auxC1+PgradC(k,l,i)
#ifdef ALLSAXS
            auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
            auxX1 = auxX1+PgradX(k,l,i)
#endif
          enddo
          gsaxsC(l,i) = auxC - auxC1/Cnorm
#ifdef ALLSAXS
          gsaxsX(l,i) = auxX - auxX1/Cnorm
#endif
c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
        enddo
      enddo
#ifdef MPI
      endif
#endif
      return
      end
c----------------------------------------------------------------------------
      subroutine e_saxsC(Esaxs_constr)
      implicit none
      include 'DIMENSIONS'
      include 'DIMENSIONS.ZSCOPT'
      include 'DIMENSIONS.FREE'
#ifdef MPI
      include "mpif.h"
      include "COMMON.SETUP"
      integer IERR
#endif
      include 'COMMON.SBRIDGE'
      include 'COMMON.CHAIN'
      include 'COMMON.GEO'
      include 'COMMON.LOCAL'
      include 'COMMON.INTERACT'
      include 'COMMON.VAR'
      include 'COMMON.IOUNITS'
      include 'COMMON.DERIV'
      include 'COMMON.CONTROL'
      include 'COMMON.NAMES'
      include 'COMMON.FFIELD'
      include 'COMMON.LANGEVIN'
      include 'COMMON.SAXS'
c
      double precision Esaxs_constr
      integer i,iint,j,k,l
      double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
#ifdef MPI
      double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
#endif
      double precision dk,dijCASPH,dijSCSPH,
     & sigma2CA,sigma2SC,expCASPH,expSCSPH,
     & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
     & auxX,auxX1,Cnorm
c  SAXS restraint penalty function
#ifdef DEBUG
      write(iout,*) "------- SAXS penalty function start -------"
      write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
     & " isaxs_end",isaxs_end
      write (iout,*) "nnt",nnt," ntc",nct
      do i=nnt,nct
        write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
     &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
      enddo
      do i=nnt,nct
        write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
      enddo
#endif
      Esaxs_constr = 0.0d0
      logPtot=0.0d0
      do j=isaxs_start,isaxs_end
        Pcalc=0.0d0
        do i=1,nres
          do l=1,3
            PgradC(l,i)=0.0d0
            PgradX(l,i)=0.0d0
          enddo
        enddo
        do i=nnt,nct
          dijCASPH=0.0d0
          dijSCSPH=0.0d0
          do l=1,3
            dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
          enddo
          if (itype(i).ne.10) then
          do l=1,3
            dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
          enddo
          endif
          sigma2CA=2.0d0/pstok**2
          sigma2SC=4.0d0/restok(itype(i))**2
          expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
          expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
          Pcalc = Pcalc+expCASPH+expSCSPH
#ifdef DEBUG
          write(*,*) "processor i j Pcalc",
     &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
#endif
          CASPHgrad = sigma2CA*expCASPH
          SCSPHgrad = sigma2SC*expSCSPH
          do l=1,3
            aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
            PgradX(l,i) = PgradX(l,i) + aux
            PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
          enddo ! l
        enddo ! i
        do i=nnt,nct
          do l=1,3
            gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
            gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
          enddo
        enddo
        logPtot = logPtot - dlog(Pcalc) 
c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
c     &    " logPtot",logPtot
      enddo ! j
#ifdef MPI
      if (nfgtasks.gt.1) then 
c        write (iout,*) "logPtot before reduction",logPtot
        call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
     &    MPI_SUM,king,FG_COMM,IERR)
        logPtot = logPtot_
c        write (iout,*) "logPtot after reduction",logPtot
        call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
     &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
        if (fg_rank.eq.king) then
          do i=1,nres
            do l=1,3
              gsaxsC(l,i) = gsaxsC_(l,i)
            enddo
          enddo
        endif
        call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
     &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
        if (fg_rank.eq.king) then
          do i=1,nres
            do l=1,3
              gsaxsX(l,i) = gsaxsX_(l,i)
            enddo
          enddo
        endif
      endif
#endif
      Esaxs_constr = logPtot
      return
      end