Merge branch 'lipid' of mmka.chem.univ.gda.pl:unres into lipid

[unres.git] / source / wham / src-NEWSC / cont_frag.f

diff --git a/source/wham/src-NEWSC/cont_frag.f b/source/wham/src-NEWSC/cont_frag.f
new file mode 100755 (executable)
index 0000000..63a7717
--- /dev/null
+++ b/source/wham/src-NEWSC/cont_frag.f
@@ -0,0 +1,99 @@
+      subroutine contacts_between_fragments(lprint,is,ncont,icont,
+     &   ncont_interfrag,icont_interfrag)
+      include 'DIMENSIONS'
+      include 'DIMENSIONS.ZSCOPT'
+      include 'DIMENSIONS.COMPAR'
+      include 'COMMON.INTERACT'
+      include 'COMMON.COMPAR'
+      include 'COMMON.IOUNITS'
+      include 'COMMON.CHAIN'
+      include 'COMMON.NAMES'
+      integer icont(2,maxcont),ncont_interfrag(mmaxfrag),
+     &  icont_interfrag(2,maxcont,mmaxfrag)
+      logical OK1,OK2,lprint
+c Determine the contacts that occur within a fragment and between fragments.
+      do i=1,nfrag(1)
+        do j=1,i
+          ind = icant(i,j)
+          nc=0
+c          write (iout,*) "i",i,(ifrag(1,k,i),ifrag(2,k,i)
+c     &      ,k=1,npiece(i,1))
+c          write (iout,*) "j",j,(ifrag(1,k,j),ifrag(2,k,j)
+c     &      ,k=1,npiece(j,1))
+c          write (iout,*) "ncont",ncont
+          do k=1,ncont
+            ic1=icont(1,k)
+            ic2=icont(2,k)
+            OK1=.false.
+            l=0
+            do while (.not.OK1 .and. l.lt.npiece(j,1)) 
+              l=l+1
+              OK1=ic1.ge.ifrag(1,l,j)-is .and. 
+     &         ic1.le.ifrag(2,l,j)+is
+            enddo
+            OK2=.false.
+            l=0
+            do while (.not.OK2 .and. l.lt.npiece(i,1)) 
+              l=l+1
+              OK2=ic2.ge.ifrag(1,l,i)-is .and. 
+     &         ic2.le.ifrag(2,l,i)+is
+            enddo 
+c            write(iout,*) "k",k," ic1",ic1," ic2",ic2," OK1",OK1,
+c     &        " OK2",OK2
+            if (OK1.and.OK2) then
+              nc=nc+1
+              icont_interfrag(1,nc,ind)=ic1 
+              icont_interfrag(2,nc,ind)=ic2 
+c              write (iout,*) "nc",nc," ic1",ic1," ic2",ic2
+            endif
+          enddo
+          ncont_interfrag(ind)=nc
+c          do k=1,ncont_interfrag(ind)
+c              i1=icont_interfrag(1,k,ind)
+c              i2=icont_interfrag(2,k,ind)
+c              it1=itype(i1)
+c              it2=itype(i2)
+c              write (iout,'(i3,2x,a,i4,2x,a,i4)')
+c     &          i,restyp(it1),i1,restyp(it2),i2
+c          enddo
+        enddo
+      enddo
+      if (lprint) then
+        write (iout,*) "Contacts within fragments:"
+        do i=1,nfrag(1)
+          write (iout,*) "Fragment",i," (",(ifrag(1,k,i),
+     &     ifrag(2,k,i),k=1,npiece(i,1)),")"
+          ind=icant(i,i)
+          do k=1,ncont_interfrag(ind)
+            i1=icont_interfrag(1,k,ind)
+            i2=icont_interfrag(2,k,ind)
+            it1=itype(i1)
+            it2=itype(i2)
+            write (iout,'(i3,2x,a,i4,2x,a,i4)')
+     &        i,restyp(it1),i1,restyp(it2),i2
+          enddo
+        enddo
+        write (iout,*)
+        write (iout,*) "Contacts between fragments:"
+        do i=1,nfrag(1)
+        do j=1,i-1
+          ind = icant(i,j)
+          write (iout,*) "Fragments",i," (",(ifrag(1,k,i),
+     &     ifrag(2,k,i),k=1,npiece(i,1)),") and",j," (",
+     &     (ifrag(1,k,j),ifrag(2,k,j),k=1,npiece(j,1)),")"
+          write (iout,*) "Number of contacts",
+     &     ncont_interfrag(ind)
+          ind=icant(i,j)
+          do k=1,ncont_interfrag(ind)
+            i1=icont_interfrag(1,k,ind)
+            i2=icont_interfrag(2,k,ind)
+            it1=itype(i1)
+            it2=itype(i2)
+            write (iout,'(i3,2x,a,i4,2x,a,i4)')
+     &        i,restyp(it1),i1,restyp(it2),i2
+          enddo
+        enddo
+        enddo
+      endif
+      return
+      end