ESSENTIAL CHANGE - BUG FIX in ENERGY to have old Correlation
[unres.git] / source / unres / src_MD-M / energy_p_new_barrier.F
index e6f630d..3e1eb6e 100644 (file)
@@ -273,6 +273,11 @@ C      print *,"przed lipidami"
         call Eliptransfer(eliptran)
       endif
 C      print *,"za lipidami"
+      if (AFMlog.gt.0) then
+        call AFMforce(Eafmforce)
+      else if (selfguide.gt.0) then
+        call AFMvel(Eafmforce)
+      endif
 #ifdef TIMING
       time_enecalc=time_enecalc+MPI_Wtime()-time00
 #endif
@@ -315,6 +320,7 @@ C
       energia(20)=Uconst+Uconst_back
       energia(21)=esccor
       energia(22)=eliptran
+      energia(23)=Eafmforce
 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"
@@ -407,13 +413,14 @@ cMS$ATTRIBUTES C ::  proc_proc
       Uconst=energia(20)
       esccor=energia(21)
       eliptran=energia(22)
+      Eafmforce=energia(23)
 #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+wliptran*eliptran
+     & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 #else
       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
      & +wang*ebe+wtor*etors+wscloc*escloc
@@ -421,6 +428,7 @@ cMS$ATTRIBUTES C ::  proc_proc
      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
      & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
+     & +Eafmforce
 #endif
       energia(0)=etot
 c detecting NaNQ
@@ -524,6 +532,7 @@ c      enddo
      &                wturn6*gcorr6_turn_long(j,i)+
      &                wstrain*ghpbc(j,i)
      &                +wliptran*gliptranc(j,i)
+     &                +gradafm(j,i)
 
         enddo
       enddo 
@@ -541,6 +550,8 @@ c      enddo
      &                wturn6*gcorr6_turn_long(j,i)+
      &                wstrain*ghpbc(j,i)
      &                +wliptran*gliptranc(j,i)
+     &                +gradafm(j,i)
+
         enddo
       enddo 
 #endif
@@ -677,6 +688,7 @@ c      enddo
      &                wsccor*gsccorc(j,i)
      &               +wscloc*gscloc(j,i)
      &               +wliptran*gliptranc(j,i)
+     &                +gradafm(j,i)
 #else
           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
      &                wel_loc*gel_loc(j,i)+
@@ -697,6 +709,8 @@ c      enddo
      &                wsccor*gsccorc(j,i)
      &               +wscloc*gscloc(j,i)
      &               +wliptran*gliptranc(j,i)
+     &                +gradafm(j,i)
+
 #endif
           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
      &                  wbond*gradbx(j,i)+
@@ -993,6 +1007,7 @@ C------------------------------------------------------------------------
       Uconst=energia(20)
       esccor=energia(21)
       eliptran=energia(22)
+      Eafmforce=energia(23) 
 #ifdef SPLITELE
       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
      &  estr,wbond,ebe,wang,
@@ -1001,7 +1016,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,eliptran,wliptran,etot
+     &  Uconst,eliptran,wliptran,Eafmforce,etot
    10 format (/'Virtual-chain energies:'//
      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
@@ -1026,7 +1041,9 @@ C------------------------------------------------------------------------
      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
      & 'UCONST= ',1pE16.6,' (Constraint energy)'/ 
      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
+     & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
      & 'ETOT=  ',1pE16.6,' (total)')
+
 #else
       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
      &  estr,wbond,ebe,wang,
@@ -1034,7 +1051,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,eliptran,wliptran,etot
+     &  ebr*nss,Uconst,eliptran,wliptran,Eafmforc,etot
    10 format (/'Virtual-chain energies:'//
      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
@@ -1058,6 +1075,7 @@ C------------------------------------------------------------------------
      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
      & 'UCONST=',1pE16.6,' (Constraint energy)'/ 
      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
+     & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
      & 'ETOT=  ',1pE16.6,' (total)')
 #endif
       return
@@ -1623,7 +1641,7 @@ C what fraction I am in
 C lipbufthick is thickenes of lipid buffore
          sslipj=sscalelip(fracinbuf)
          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
-        elseif (zi.gt.bufliptop) then
+        elseif (zj.gt.bufliptop) then
          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
          sslipj=sscalelip(fracinbuf)
          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
@@ -1825,12 +1843,12 @@ C the energy transfer exist
         if (zi.lt.buflipbot) then
 C what fraction I am in
          fracinbuf=1.0d0-
-     &        ((positi-bordlipbot)/lipbufthick)
+     &        ((zi-bordlipbot)/lipbufthick)
 C lipbufthick is thickenes of lipid buffore
          sslipi=sscalelip(fracinbuf)
          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
         elseif (zi.gt.bufliptop) then
-         fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
+         fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
          sslipi=sscalelip(fracinbuf)
          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
         else
@@ -1893,12 +1911,12 @@ C the energy transfer exist
         if (zj.lt.buflipbot) then
 C what fraction I am in
          fracinbuf=1.0d0-
-     &        ((positi-bordlipbot)/lipbufthick)
+     &        ((zj-bordlipbot)/lipbufthick)
 C lipbufthick is thickenes of lipid buffore
          sslipj=sscalelip(fracinbuf)
          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
-        elseif (zi.gt.bufliptop) then
-         fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
+        elseif (zj.gt.bufliptop) then
+         fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
          sslipj=sscalelip(fracinbuf)
          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
         else
@@ -2700,12 +2718,37 @@ c       write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
 c       write(iout,*)  'b1=',b1(1,i-2)
 c       write (iout,*) 'theta=', theta(i-1)
        enddo
+#else
+        if (i.gt. nnt+2 .and. i.lt.nct+2) then
+          iti = itortyp(itype(i-2))
+        else
+          iti=ntortyp+1
+        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 = itortyp(itype(i-1))
+        else
+          iti1=ntortyp+1
+        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)
+       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)
+        EE(1,2,i-2)=eeold(1,2,iti)
+        EE(2,1,i-2)=eeold(2,1,iti)
+        EE(2,2,i-2)=eeold(2,2,iti)
+        EE(1,1,i-2)=eeold(1,1,iti)
+      enddo
+#endif
 #ifdef PARMAT
       do i=ivec_start+2,ivec_end+2
 #else
       do i=3,nres+1
 #endif
-#endif
         if (i .lt. nres+1) then
           sin1=dsin(phi(i))
           cos1=dcos(phi(i))
@@ -2841,6 +2884,7 @@ c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
         do k=1,2
           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
         enddo
+C        write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
 c        write (iout,*) 'mu ',mu(:,i-2),i-2
 cd        write (iout,*) 'mu1',mu1(:,i-2)
 cd        write (iout,*) 'mu2',mu2(:,i-2)
@@ -3253,11 +3297,18 @@ C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
         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
+     & .or.((i+4).gt.nres)
+     & .or.((i-1).le.0)
+C end of changes by Ana
      &  .or. itype(i+2).eq.ntyp1
-     &  .or. itype(i+3).eq.ntyp1
-     &  .or. itype(i-1).eq.ntyp1
-     &  .or. itype(i+4).eq.ntyp1
-     &  ) cycle
+     &  .or. itype(i+3).eq.ntyp1) cycle
+        if(i.gt.1)then
+          if(itype(i-1).eq.ntyp1)cycle
+        end if
+        if(i.LT.nres-3)then
+          if (itype(i+4).eq.ntyp1) cycle
+        end if
         dxi=dc(1,i)
         dyi=dc(2,i)
         dzi=dc(3,i)
@@ -3281,6 +3332,10 @@ C        write(iout,*) "tu jest i",i
       do i=iturn4_start,iturn4_end
         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
+     & .or.((i+5).gt.nres)
+     & .or.((i-1).le.0)
+C end of changes suggested by Ana
      &    .or. itype(i+3).eq.ntyp1
      &    .or. itype(i+4).eq.ntyp1
      &    .or. itype(i+5).eq.ntyp1
@@ -3345,6 +3400,10 @@ c
       do i=iatel_s,iatel_e
         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
+     & .or.((i+2).gt.nres)
+     & .or.((i-1).le.0)
+C end of changes by Ana
      &  .or. itype(i+2).eq.ntyp1
      &  .or. itype(i-1).eq.ntyp1
      &                ) cycle
@@ -3399,6 +3458,10 @@ c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
 C          write (iout,*) i,j
          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
+     & .or.((j+2).gt.nres)
+     & .or.((j-1).le.0)
+C end of changes by Ana
      & .or.itype(j+2).eq.ntyp1
      & .or.itype(j-1).eq.ntyp1
      &) cycle
@@ -3936,7 +3999,7 @@ C Contribution to the local-electrostatic energy coming from the i-j pair
      &     +a33*muij(4)
 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
 c     &                     ' eel_loc_ij',eel_loc_ij
-c          write(iout,*) 'muije=',muij(1),muij(2),muij(3),muij(4)
+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)
@@ -10210,3 +10273,80 @@ C       eliptran=elpitran+0.0 ! I am in water
        enddo
        return
        end
+C---------------------------------------------------------
+C AFM soubroutine for constant force
+       subroutine AFMforce(Eafmforce)
+       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'
+      real*8 diffafm(3)
+      dist=0.0d0
+      Eafmforce=0.0d0
+      do i=1,3
+      diffafm(i)=c(i,afmend)-c(i,afmbeg)
+      dist=dist+diffafm(i)**2
+      enddo
+      dist=dsqrt(dist)
+      Eafmforce=-forceAFMconst*(dist-distafminit)
+      do i=1,3
+      gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
+      gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
+      enddo
+C      print *,'AFM',Eafmforce
+      return
+      end
+C---------------------------------------------------------
+C AFM subroutine with pseudoconstant velocity
+       subroutine AFMvel(Eafmforce)
+       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'
+      real*8 diffafm(3)
+C Only for check grad COMMENT if not used for checkgrad
+C      totT=3.0d0
+C--------------------------------------------------------
+C      print *,"wchodze"
+      dist=0.0d0
+      Eafmforce=0.0d0
+      do i=1,3
+      diffafm(i)=c(i,afmend)-c(i,afmbeg)
+      dist=dist+diffafm(i)**2
+      enddo
+      dist=dsqrt(dist)
+      Eafmforce=0.5d0*forceAFMconst
+     & *(distafminit+totTafm*velAFMconst-dist)**2
+C      Eafmforce=-forceAFMconst*(dist-distafminit)
+      do i=1,3
+      gradafm(i,afmend-1)=-forceAFMconst*
+     &(distafminit+totTafm*velAFMconst-dist)
+     &*diffafm(i)/dist
+      gradafm(i,afmbeg-1)=forceAFMconst*
+     &(distafminit+totTafm*velAFMconst-dist)
+     &*diffafm(i)/dist
+      enddo
+C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
+      return
+      end
+