wprowadzenie lipidow
[unres.git] / source / unres / src_MD-M / energy_p_new_barrier.F
index 23aafae..7207b35 100644 (file)
@@ -122,6 +122,11 @@ C
 C Calculate electrostatic (H-bonding) energy of the main chain.
 C
   107 continue
+cmc
+cmc Sep-06: egb takes care of dynamic ss bonds too
+cmc
+c      if (dyn_ss) call dyn_set_nss
+
 c      print *,"Processor",myrank," computed USCSC"
 #ifdef TIMING
       time01=MPI_Wtime() 
@@ -194,6 +199,7 @@ c      print *,"Processor",myrank," computed UB"
 C
 C Calculate the SC local energy.
 C
+C      print *,"TU DOCHODZE?"
       call esc(escloc)
 c      print *,"Processor",myrank," computed USC"
 C
@@ -224,6 +230,7 @@ C
       else
         esccor=0.0d0
       endif
+C      print *,"PRZED MULIt"
 c      print *,"Processor",myrank," computed Usccorr"
 C 
 C 12/1/95 Multi-body terms
@@ -256,6 +263,14 @@ C  after the equilibration time
          Uconst=0.0d0
          Uconst_back=0.0d0
       endif
+C 01/27/2015 added by adasko
+C the energy component below is energy transfer into lipid environment 
+C based on partition function
+C      print *,"przed lipidami"
+      if (wliptran.gt.0) then
+        call Eliptransfer(eliptran)
+      endif
+C      print *,"za lipidami"
 #ifdef TIMING
       time_enecalc=time_enecalc+MPI_Wtime()-time00
 #endif
@@ -297,10 +312,12 @@ C
       energia(17)=estr
       energia(20)=Uconst+Uconst_back
       energia(21)=esccor
+      energia(22)=eliptran
 c    Here are the energies showed per procesor if the are more processors 
 c    per molecule then we sum it up in sum_energy subroutine 
 c      print *," Processor",myrank," calls SUM_ENERGY"
       call sum_energy(energia,.true.)
+      if (dyn_ss) call dyn_set_nss
 c      print *," Processor",myrank," left SUM_ENERGY"
 #ifdef TIMING
       time_sumene=time_sumene+MPI_Wtime()-time00
@@ -387,20 +404,21 @@ cMS$ATTRIBUTES C ::  proc_proc
       estr=energia(17)
       Uconst=energia(20)
       esccor=energia(21)
+      eliptran=energia(22)
 #ifdef SPLITELE
       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
      & +wang*ebe+wtor*etors+wscloc*escloc
      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
-     & +wbond*estr+Uconst+wsccor*esccor
+     & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 #else
       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
      & +wang*ebe+wtor*etors+wscloc*escloc
      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
-     & +wbond*estr+Uconst+wsccor*esccor
+     & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
 #endif
       energia(0)=etot
 c detecting NaNQ
@@ -436,9 +454,9 @@ cMS$ATTRIBUTES C ::  proc_proc
 #endif
 #ifdef MPI
       include 'mpif.h'
-      double precision gradbufc(3,maxres),gradbufx(3,maxres),
-     &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 #endif
+      double precision gradbufc(3,0:maxres),gradbufx(3,0:maxres),
+     & glocbuf(4*maxres),gradbufc_sum(3,0:maxres),gloc_scbuf(3,0:maxres)
       include 'COMMON.SETUP'
       include 'COMMON.IOUNITS'
       include 'COMMON.FFIELD'
@@ -502,6 +520,8 @@ c      enddo
      &                wcorr6*gradcorr6_long(j,i)+
      &                wturn6*gcorr6_turn_long(j,i)+
      &                wstrain*ghpbc(j,i)
+     &                +wliptran*gliptranc(j,i)
+
         enddo
       enddo 
 #else
@@ -517,6 +537,7 @@ c      enddo
      &                wcorr6*gradcorr6_long(j,i)+
      &                wturn6*gcorr6_turn_long(j,i)+
      &                wstrain*ghpbc(j,i)
+     &                +wliptran*gliptranc(j,i)
         enddo
       enddo 
 #endif
@@ -652,6 +673,7 @@ c      enddo
      &                wturn6*gcorr6_turn(j,i)+
      &                wsccor*gsccorc(j,i)
      &               +wscloc*gscloc(j,i)
+     &               +wliptran*gliptranc(j,i)
 #else
           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
      &                wel_loc*gel_loc(j,i)+
@@ -671,12 +693,14 @@ c      enddo
      &                wturn6*gcorr6_turn(j,i)+
      &                wsccor*gsccorc(j,i)
      &               +wscloc*gscloc(j,i)
+     &               +wliptran*gliptranc(j,i)
 #endif
           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*gsccorx(j,i)
      &                 +wscloc*gsclocx(j,i)
+     &                 +wliptran*gliptranx(j,i)
         enddo
       enddo 
 #ifdef DEBUG
@@ -965,6 +989,7 @@ C------------------------------------------------------------------------
       estr=energia(17)
       Uconst=energia(20)
       esccor=energia(21)
+      eliptran=energia(22)
 #ifdef SPLITELE
       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
      &  estr,wbond,ebe,wang,
@@ -973,7 +998,7 @@ C------------------------------------------------------------------------
      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
      &  edihcnstr,ebr*nss,
-     &  Uconst,etot
+     &  Uconst,eliptran,wliptran,etot
    10 format (/'Virtual-chain energies:'//
      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
@@ -997,6 +1022,7 @@ C------------------------------------------------------------------------
      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
      & 'UCONST= ',1pE16.6,' (Constraint energy)'/ 
+     & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
      & 'ETOT=  ',1pE16.6,' (total)')
 #else
       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
@@ -1005,7 +1031,7 @@ C------------------------------------------------------------------------
      &  ecorr,wcorr,
      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
-     &  ebr*nss,Uconst,etot
+     &  ebr*nss,Uconst,eliptran,wliptran,etot
    10 format (/'Virtual-chain energies:'//
      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
@@ -1028,6 +1054,7 @@ C------------------------------------------------------------------------
      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
      & 'UCONST=',1pE16.6,' (Constraint energy)'/ 
+     & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
      & 'ETOT=  ',1pE16.6,' (total)')
 #endif
       return
@@ -1082,6 +1109,7 @@ C Change 12/1/95 to calculate four-body interactions
 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
             eps0ij=eps(itypi,itypj)
             fac=rrij**expon2
+C have you changed here?
             e1=fac*fac*aa(itypi,itypj)
             e2=fac*bb(itypi,itypj)
             evdwij=e1+e2
@@ -1232,6 +1260,7 @@ C
             rij=1.0D0/r_inv_ij 
             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
             fac=r_shift_inv**expon
+C have you changed here?
             e1=fac*fac*aa(itypi,itypj)
             e2=fac*bb(itypi,itypj)
             evdwij=e_augm+e1+e2
@@ -1359,6 +1388,7 @@ 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
+C have you changed here?
             fac=(rrij*sigsq)**expon2
             e1=fac*fac*aa(itypi,itypj)
             e2=fac*bb(itypi,itypj)
@@ -1414,6 +1444,7 @@ C
       include 'COMMON.CALC'
       include 'COMMON.CONTROL'
       include 'COMMON.SPLITELE'
+      include 'COMMON.SBRIDGE'
       logical lprn
       integer xshift,yshift,zshift
       evdw=0.0D0
@@ -1482,6 +1513,12 @@ 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
+              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') 
+     &                        'evdw',i,j,evdwij,' ss'
+            ELSE
             ind=ind+1
             itypj=iabs(itype(j))
             if (itypj.eq.ntyp1) cycle
@@ -1612,6 +1649,8 @@ cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
 c---------------------------------------------------------------
             rij_shift=1.0D0/rij_shift 
             fac=rij_shift**expon
+C here to start with
+C            if (c(i,3).gt.
             e1=fac*fac*aa(itypi,itypj)
             e2=fac*bb(itypi,itypj)
             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
@@ -1651,6 +1690,7 @@ C Calculate the radial part of the gradient
 C Calculate angular part of the gradient.
             call sc_grad
             endif
+            ENDIF    ! dyn_ss            
           enddo      ! j
         enddo        ! iint
       enddo          ! i
@@ -2010,7 +2050,7 @@ C
       include 'COMMON.VECTORS'
       include 'COMMON.FFIELD'
       dimension ggg(3)
-cd      write(iout,*) 'In EELEC_soft_sphere'
+C      write(iout,*) 'In EELEC_soft_sphere'
       ees=0.0D0
       evdw1=0.0D0
       eel_loc=0.0d0 
@@ -2025,6 +2065,12 @@ cd      write(iout,*) 'In EELEC_soft_sphere'
         xmedi=c(1,i)+0.5d0*dxi
         ymedi=c(2,i)+0.5d0*dyi
         zmedi=c(3,i)+0.5d0*dzi
+          xmedi=mod(xmedi,boxxsize)
+          if (xmedi.lt.0) xmedi=xmedi+boxxsize
+          ymedi=mod(ymedi,boxysize)
+          if (ymedi.lt.0) ymedi=ymedi+boxysize
+          zmedi=mod(zmedi,boxzsize)
+          if (zmedi.lt.0) zmedi=zmedi+boxzsize
         num_conti=0
 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
         do j=ielstart(i),ielend(i)
@@ -2038,10 +2084,49 @@ c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
           dxj=dc(1,j)
           dyj=dc(2,j)
           dzj=dc(3,j)
-          xj=c(1,j)+0.5D0*dxj-xmedi
-          yj=c(2,j)+0.5D0*dyj-ymedi
-          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
+          xj=mod(xj,boxxsize)
+          if (xj.lt.0) xj=xj+boxxsize
+          yj=mod(yj,boxysize)
+          if (yj.lt.0) yj=yj+boxysize
+          zj=mod(zj,boxzsize)
+          if (zj.lt.0) zj=zj+boxzsize
+      dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
+      xj_safe=xj
+      yj_safe=yj
+      zj_safe=zj
+      isubchap=0
+      do xshift=-1,1
+      do yshift=-1,1
+      do zshift=-1,1
+          xj=xj_safe+xshift*boxxsize
+          yj=yj_safe+yshift*boxysize
+          zj=zj_safe+zshift*boxzsize
+          dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+          if(dist_temp.lt.dist_init) then
+            dist_init=dist_temp
+            xj_temp=xj
+            yj_temp=yj
+            zj_temp=zj
+            isubchap=1
+          endif
+       enddo
+       enddo
+       enddo
+       if (isubchap.eq.1) then
+          xj=xj_temp-xmedi
+          yj=yj_temp-ymedi
+          zj=zj_temp-zmedi
+       else
+          xj=xj_safe-xmedi
+          yj=yj_safe-ymedi
+          zj=zj_safe-zmedi
+       endif
           rij=xj*xj+yj*yj+zj*zj
+            sss=sscale(sqrt(rij))
+            sssgrad=sscagrad(sqrt(rij))
           if (rij.lt.r0ijsq) then
             evdw1ij=0.25d0*(rij-r0ijsq)**2
             fac=rij-r0ijsq
@@ -2049,13 +2134,13 @@ c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
             evdw1ij=0.0d0
             fac=0.0d0
           endif
-          evdw1=evdw1+evdw1ij
+          evdw1=evdw1+evdw1ij*sss
 C
 C Calculate contributions to the Cartesian gradient.
 C
-          ggg(1)=fac*xj
-          ggg(2)=fac*yj
-          ggg(3)=fac*zj
+          ggg(1)=fac*xj*sssgrad
+          ggg(2)=fac*yj*sssgrad
+          ggg(3)=fac*zj*sssgrad
           do k=1,3
             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
@@ -2913,6 +2998,8 @@ 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
+        if (i.le.1) cycle
+C        write(iout,*) "tu jest i",i
         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
      &  .or. itype(i+2).eq.ntyp1
      &  .or. itype(i+3).eq.ntyp1
@@ -2928,31 +3015,6 @@ C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
         xmedi=c(1,i)+0.5d0*dxi
         ymedi=c(2,i)+0.5d0*dyi
         zmedi=c(3,i)+0.5d0*dzi
-C Return atom into box, boxxsize is size of box in x dimension
-c  184   continue
-c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
-c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
-C Condition for being inside the proper box
-c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
-c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
-c        go to 184
-c        endif
-c  185   continue
-c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
-c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
-cC Condition for being inside the proper box
-c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
-c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
-c        go to 185
-c        endif
-c  186   continue
-c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
-c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
-cC Condition for being inside the proper box
-c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
-c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
-c        go to 186
-c        endif
           xmedi=mod(xmedi,boxxsize)
           if (xmedi.lt.0) xmedi=xmedi+boxxsize
           ymedi=mod(ymedi,boxysize)
@@ -2965,6 +3027,7 @@ c        endif
         num_cont_hb(i)=num_conti
       enddo
       do i=iturn4_start,iturn4_end
+        if (i.le.1) cycle
         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
      &    .or. itype(i+3).eq.ntyp1
      &    .or. itype(i+4).eq.ntyp1
@@ -3027,6 +3090,7 @@ c
 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
 c
       do i=iatel_s,iatel_e
+        if (i.le.1) cycle
         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
      &  .or. itype(i+2).eq.ntyp1
      &  .or. itype(i-1).eq.ntyp1
@@ -3079,7 +3143,8 @@ c        endif
 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
         num_conti=num_cont_hb(i)
         do j=ielstart(i),ielend(i)
-c          write (iout,*) i,j,itype(i),itype(j)
+C          write (iout,*) i,j
+         if (j.le.1) cycle
           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
      & .or.itype(j+2).eq.ntyp1
      & .or.itype(j-1).eq.ntyp1
@@ -3169,7 +3234,8 @@ C          zj=c(3,j)+0.5D0*dzj-zmedi
           if (yj.lt.0) yj=yj+boxysize
           zj=mod(zj,boxzsize)
           if (zj.lt.0) zj=zj+boxzsize
-      dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+          if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
+      dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
       xj_safe=xj
       yj_safe=yj
       zj_safe=zj
@@ -3180,7 +3246,7 @@ C          zj=c(3,j)+0.5D0*dzj-zmedi
           xj=xj_safe+xshift*boxxsize
           yj=yj_safe+yshift*boxysize
           zj=zj_safe+zshift*boxzsize
-          dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
+          dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
           if(dist_temp.lt.dist_init) then
             dist_init=dist_temp
             xj_temp=xj
@@ -4611,50 +4677,58 @@ C iii and jjj point to the residues for which the distance is assigned.
           iii=ii
           jjj=jj
         endif
-cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
+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.
-        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
-     & iabs(itype(jjj)).eq.1) then
+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. itype(iii).eq.1 .and. itype(jjj).eq.1) then 
           call ssbond_ene(iii,jjj,eij)
           ehpb=ehpb+2*eij
+         endif
 cd          write (iout,*) "eij",eij
         else
 C Calculate the distance between the two points and its difference from the
 C target distance.
-        dd=dist(ii,jj)
-        rdis=dd-dhpb(i)
+          dd=dist(ii,jj)
+            rdis=dd-dhpb(i)
 C Get the force constant corresponding to this distance.
-        waga=forcon(i)
+            waga=forcon(i)
 C Calculate the contribution to energy.
-        ehpb=ehpb+waga*rdis*rdis
+            ehpb=ehpb+waga*rdis*rdis
 C
 C Evaluate gradient.
 C
-        fac=waga*rdis/dd
+            fac=waga*rdis/dd
 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
 cd   &   ' waga=',waga,' fac=',fac
-        do j=1,3
-          ggg(j)=fac*(c(j,jj)-c(j,ii))
-        enddo
+            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
+          if (iii.lt.ii) then
           do j=1,3
             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
           enddo
-        endif
+          endif
 cgrad        do j=iii,jjj-1
 cgrad          do k=1,3
 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
 cgrad          enddo
 cgrad        enddo
-        do k=1,3
-          ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
-          ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
-        enddo
+          do k=1,3
+            ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
+            ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
+          enddo
         endif
       enddo
       ehpb=0.5D0*ehpb
@@ -8614,12 +8688,12 @@ C                                                                              C
 C          o             o                                                     C
 C     \   /l\           /j\   /                                                C
 C      \ /   \         /   \ /                                                 C
-C       o| o |         | o |o                                                  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
+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, 
@@ -8790,10 +8864,10 @@ c----------------------------------------------------------------------------
       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
       logical swap
 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C                                                                              C
+C                                                                              C 
 C      Parallel       Antiparallel                                             C
 C                                                                              C
-C          o             o                                                     C
+C          o             o                                                     C 
 C         /l\   /   \   /j\                                                    C 
 C        /   \ /     \ /   \                                                   C
 C       /| o |o       o| o |\                                                  C
@@ -8907,7 +8981,7 @@ c----------------------------------------------------------------------------
      & auxvec1(2),auxmat1(2,2)
       logical swap
 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C                                                                              C
+C                                                                              C                       
 C      Parallel       Antiparallel                                             C
 C                                                                              C
 C          o             o                                                     C
@@ -8915,10 +8989,10 @@ C         /l\   /   \   /j\                                                    C
 C        /   \ /     \ /   \                                                   C
 C       /| o |o       o| o |\                                                  C
 C     \ j|/k\|      \  |/k\|l                                                  C
-C      \ /   \       \ /   \                                                   C
+C      \ /   \       \ /   \                                                   C 
 C       o     \       o     \                                                  C
 C       i             i                                                        C
-C                                                                              C
+C                                                                              C 
 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 C
 C 4/7/01 AL Component s1 was removed, because it pertains to the respective 
@@ -9618,4 +9692,116 @@ crc      print *,((prod(i,j),i=1,2),j=1,2)
 
       return
       end
+CCC----------------------------------------------
+      subroutine Eliptransfer(eliptran)
+      implicit real*8 (a-h,o-z)
+      include 'DIMENSIONS'
+      include 'COMMON.GEO'
+      include 'COMMON.VAR'
+      include 'COMMON.LOCAL'
+      include 'COMMON.CHAIN'
+      include 'COMMON.DERIV'
+      include 'COMMON.NAMES'
+      include 'COMMON.INTERACT'
+      include 'COMMON.IOUNITS'
+      include 'COMMON.CALC'
+      include 'COMMON.CONTROL'
+      include 'COMMON.SPLITELE'
+      include 'COMMON.SBRIDGE'
+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=ilip_start,ilip_end
+        if (itype(i).eq.ntyp1) cycle
+
+        positi=(mod((c(3,i)+c(3,i+1)),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.0
+         gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0
+C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
 
+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*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
+          print *, "doing sscalefor top part"
+        else
+         eliptran=eliptran+pepliptran
+         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
+       do i=ilip_start,ilip_end
+        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)
+       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))/2.0d0
+         gliptranc(3,i-1)=
+     &+ssgradlip*liptranene(itype(i))
+         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))/2.0d0
+         gliptranc(3,i-1)=
+     &+ssgradlip*liptranene(itype(i))
+          print *, "doing sscalefor top part",sslip,fracinbuf
+        else
+         eliptran=eliptran+liptranene(itype(i))
+         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