Merge branch 'lipid' of mmka.chem.univ.gda.pl:unres into lipid
[unres.git] / source / wham / src-NEWSC-NEWCORR / geomout.F
diff --git a/source/wham/src-NEWSC-NEWCORR/geomout.F b/source/wham/src-NEWSC-NEWCORR/geomout.F
new file mode 100644 (file)
index 0000000..d52e23e
--- /dev/null
@@ -0,0 +1,167 @@
+      subroutine pdbout(ii,temp,efree,etot,entropy,rmsdev)
+      implicit real*8 (a-h,o-z)
+      include 'DIMENSIONS'
+      include 'DIMENSIONS.ZSCOPT'
+      include 'COMMON.CHAIN'
+      include 'COMMON.INTERACT'
+      include 'COMMON.NAMES'
+      include 'COMMON.IOUNITS'
+      include 'COMMON.HEADER'
+      include 'COMMON.SBRIDGE'
+      character*50 tytul
+      dimension ica(maxres)
+      write(ipdb,'("REMARK CONF",i8," TEMPERATURE",f7.1," RMS",0pf7.2)') 
+     &  ii,temp,rmsdev
+      write (ipdb,'("REMARK DIMENSIONLESS FREE ENERGY",1pe15.5)') 
+     &  efree
+      write (ipdb,'("REMARK ENERGY",1pe15.5," ENTROPY",1pe15.5)') 
+     &  etot,entropy
+      iatom=0
+      do i=nnt,nct
+        ires=i-nnt+1
+        iatom=iatom+1
+        ica(i)=iatom
+        iti=itype(i)
+        write (ipdb,10) iatom,restyp(iti),ires,(c(j,i),j=1,3)
+        if (iti.ne.10) then
+          iatom=iatom+1
+          write (ipdb,20) iatom,restyp(iti),ires,(c(j,nres+i),j=1,3)
+        endif
+      enddo
+      write (ipdb,'(a)') 'TER'
+      do i=nnt,nct-1
+        if (itype(i).eq.10) then
+          write (ipdb,30) ica(i),ica(i+1)
+        else
+          write (ipdb,30) ica(i),ica(i+1),ica(i)+1
+        endif
+      enddo
+      if (itype(nct).ne.10) then
+        write (ipdb,30) ica(nct),ica(nct)+1
+      endif
+      do i=1,nss
+        write (ipdb,30) ica(ihpb(i))+1,ica(jhpb(i))+1
+      enddo
+      write (ipdb,'(a)') "END"
+  10  FORMAT ('ATOM',I7,'  CA  ',A3,I6,4X,3F8.3)
+  20  FORMAT ('ATOM',I7,'  CB  ',A3,I6,4X,3F8.3)
+  30  FORMAT ('CONECT',8I5)
+      return
+      end
+c------------------------------------------------------------------------------
+      subroutine MOL2out(etot,tytul)
+C Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2 
+C format.
+      implicit real*8 (a-h,o-z)
+      include 'DIMENSIONS'
+      include 'DIMENSIONS.ZSCOPT'
+      include 'COMMON.CHAIN'
+      include 'COMMON.INTERACT'
+      include 'COMMON.NAMES'
+      include 'COMMON.IOUNITS'
+      include 'COMMON.HEADER'
+      include 'COMMON.SBRIDGE'
+      character*32 tytul,fd
+      character*3 liczba
+      character*6 res_num,pom,ucase
+#ifdef AIX
+      call fdate_(fd)
+#else
+      call fdate(fd)
+#endif
+      write (imol2,'(a)') '#'
+      write (imol2,'(a)') 
+     & '#         Creating user name:           unres'
+      write (imol2,'(2a)') '#         Creation time:                ',
+     & fd
+      write (imol2,'(/a)') '\@<TRIPOS>MOLECULE'
+      write (imol2,'(a)') tytul
+      write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0
+      write (imol2,'(a)') 'SMALL'
+      write (imol2,'(a)') 'USER_CHARGES'
+      write (imol2,'(a)') '\@<TRIPOS>ATOM' 
+      do i=nnt,nct
+        write (liczba,*) i
+        pom=ucase(restyp(itype(i)))
+        res_num = pom(:3)//liczba(2:)
+        write (imol2,10) i,(c(j,i),j=1,3),i,res_num,0.0
+      enddo
+      write (imol2,'(a)') '\@<TRIPOS>BOND'
+      do i=nnt,nct-1
+        write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1
+      enddo
+      do i=1,nss
+        write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1
+      enddo
+      write (imol2,'(a)') '\@<TRIPOS>SUBSTRUCTURE'
+      do i=nnt,nct
+        write (liczba,*) i
+        pom = ucase(restyp(itype(i)))
+        res_num = pom(:3)//liczba(2:)
+        write (imol2,30) i-nnt+1,res_num,i-nnt+1,0
+      enddo
+  10  FORMAT (I7,' CA      ',3F10.4,' C.3',I8,1X,A,F11.4,' ****')
+  30  FORMAT (I7,1x,A,I14,' RESIDUE',I13,' ****  ****')
+      return
+      end
+c------------------------------------------------------------------------
+      subroutine intout
+      implicit real*8 (a-h,o-z)
+      include 'DIMENSIONS'
+      include 'DIMENSIONS.ZSCOPT'
+      include 'COMMON.IOUNITS'
+      include 'COMMON.CHAIN'
+      include 'COMMON.VAR'
+      include 'COMMON.LOCAL'
+      include 'COMMON.INTERACT'
+      include 'COMMON.NAMES'
+      include 'COMMON.GEO'
+      write (iout,'(/a)') 'Geometry of the virtual chain.'
+      write (iout,'(7a)') '  Res  ','      Dpep','     Theta',
+     & '       Phi','       Dsc','     Alpha','      Omega'
+      do i=1,nres
+       iti=itype(i)
+        write (iout,'(a3,i4,6f10.3)') restyp(iti),i,vbld(i+1),
+     &     rad2deg*theta(i),
+     &     rad2deg*phi(i),vbld(nres+i),rad2deg*alph(i),rad2deg*omeg(i)
+      enddo
+      return
+      end
+c---------------------------------------------------------------------------
+      subroutine briefout(it,ener)
+      implicit real*8 (a-h,o-z)
+      include 'DIMENSIONS'
+      include 'DIMENSIONS.ZSCOPT'
+      include 'COMMON.IOUNITS'
+      include 'COMMON.CHAIN'
+      include 'COMMON.VAR'
+      include 'COMMON.LOCAL'
+      include 'COMMON.INTERACT'
+      include 'COMMON.NAMES'
+      include 'COMMON.GEO'
+      include 'COMMON.SBRIDGE'
+      print '(a,i5)',intname,igeom
+#if defined(AIX) || defined(PGI)
+      open (igeom,file=intname,position='append')
+#else
+      open (igeom,file=intname,access='append')
+#endif
+      IF (NSS.LE.9) THEN
+        WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS)
+      ELSE
+        WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9)
+        WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS)
+      ENDIF
+c     IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
+      WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
+      WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES)
+c     if (nvar.gt.nphi+ntheta) then
+        write (igeom,200) (rad2deg*alph(i),i=2,nres-1)
+        write (igeom,200) (rad2deg*omeg(i),i=2,nres-1)
+c     endif
+      close(igeom)
+  180 format (I5,F12.3,I2,9(1X,2I3))
+  190 format (3X,11(1X,2I3))
+  200 format (8F10.4)
+      return
+      end