small fix in .gitingnore
[unres.git] / source / wham / src / geomout.F
1       subroutine pdbout(ii,temp,efree,etot,entropy,rmsdev)
2       implicit real*8 (a-h,o-z)
3       include 'DIMENSIONS'
4       include 'DIMENSIONS.ZSCOPT'
5       include 'COMMON.CHAIN'
6       include 'COMMON.INTERACT'
7       include 'COMMON.NAMES'
8       include 'COMMON.IOUNITS'
9       include 'COMMON.HEADER'
10       include 'COMMON.SBRIDGE'
11       character*50 tytul
12       dimension ica(maxres)
13       write(ipdb,'("REMARK CONF",i8," TEMPERATURE",f7.1," RMS",0pf7.2)') 
14      &  ii,temp,rmsdev
15       write (ipdb,'("REMARK DIMENSIONLESS FREE ENERGY",1pe15.5)') 
16      &  efree
17       write (ipdb,'("REMARK ENERGY",1pe15.5," ENTROPY",1pe15.5)') 
18      &  etot,entropy
19       iatom=0
20       do i=nnt,nct
21         ires=i-nnt+1
22         iatom=iatom+1
23         ica(i)=iatom
24         iti=itype(i)
25         write (ipdb,10) iatom,restyp(iti),ires,(c(j,i),j=1,3)
26         if (iti.ne.10) then
27           iatom=iatom+1
28           write (ipdb,20) iatom,restyp(iti),ires,(c(j,nres+i),j=1,3)
29         endif
30       enddo
31       write (ipdb,'(a)') 'TER'
32       do i=nnt,nct-1
33         if (itype(i).eq.10) then
34           write (ipdb,30) ica(i),ica(i+1)
35         else
36           write (ipdb,30) ica(i),ica(i+1),ica(i)+1
37         endif
38       enddo
39       if (itype(nct).ne.10) then
40         write (ipdb,30) ica(nct),ica(nct)+1
41       endif
42       do i=1,nss
43         write (ipdb,30) ica(ihpb(i))+1,ica(jhpb(i))+1
44       enddo
45   10  FORMAT ('ATOM',I7,'  CA  ',A3,I6,4X,3F8.3)
46   20  FORMAT ('ATOM',I7,'  CB  ',A3,I6,4X,3F8.3)
47   30  FORMAT ('CONECT',8I5)
48       return
49       end
50 c------------------------------------------------------------------------------
51       subroutine MOL2out(etot,tytul)
52 C Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2 
53 C format.
54       implicit real*8 (a-h,o-z)
55       include 'DIMENSIONS'
56       include 'DIMENSIONS.ZSCOPT'
57       include 'COMMON.CHAIN'
58       include 'COMMON.INTERACT'
59       include 'COMMON.NAMES'
60       include 'COMMON.IOUNITS'
61       include 'COMMON.HEADER'
62       include 'COMMON.SBRIDGE'
63       character*32 tytul,fd
64       character*3 liczba
65       character*6 res_num,pom,ucase
66 #ifdef AIX
67       call fdate_(fd)
68 #else
69       call fdate(fd)
70 #endif
71       write (imol2,'(a)') '#'
72       write (imol2,'(a)') 
73      & '#         Creating user name:           unres'
74       write (imol2,'(2a)') '#         Creation time:                ',
75      & fd
76       write (imol2,'(/a)') '\@<TRIPOS>MOLECULE'
77       write (imol2,'(a)') tytul
78       write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0
79       write (imol2,'(a)') 'SMALL'
80       write (imol2,'(a)') 'USER_CHARGES'
81       write (imol2,'(a)') '\@<TRIPOS>ATOM' 
82       do i=nnt,nct
83         write (liczba,*) i
84         pom=ucase(restyp(itype(i)))
85         res_num = pom(:3)//liczba(2:)
86         write (imol2,10) i,(c(j,i),j=1,3),i,res_num,0.0
87       enddo
88       write (imol2,'(a)') '\@<TRIPOS>BOND'
89       do i=nnt,nct-1
90         write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1
91       enddo
92       do i=1,nss
93         write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1
94       enddo
95       write (imol2,'(a)') '\@<TRIPOS>SUBSTRUCTURE'
96       do i=nnt,nct
97         write (liczba,*) i
98         pom = ucase(restyp(itype(i)))
99         res_num = pom(:3)//liczba(2:)
100         write (imol2,30) i-nnt+1,res_num,i-nnt+1,0
101       enddo
102   10  FORMAT (I7,' CA      ',3F10.4,' C.3',I8,1X,A,F11.4,' ****')
103   30  FORMAT (I7,1x,A,I14,' RESIDUE',I13,' ****  ****')
104       return
105       end
106 c------------------------------------------------------------------------
107       subroutine intout
108       implicit real*8 (a-h,o-z)
109       include 'DIMENSIONS'
110       include 'DIMENSIONS.ZSCOPT'
111       include 'COMMON.IOUNITS'
112       include 'COMMON.CHAIN'
113       include 'COMMON.VAR'
114       include 'COMMON.LOCAL'
115       include 'COMMON.INTERACT'
116       include 'COMMON.NAMES'
117       include 'COMMON.GEO'
118       write (iout,'(/a)') 'Geometry of the virtual chain.'
119       write (iout,'(7a)') '  Res  ','      Dpep','     Theta',
120      & '       Phi','       Dsc','     Alpha','      Omega'
121       do i=1,nres
122         iti=itype(i)
123         write (iout,'(a3,i4,6f10.3)') restyp(iti),i,vbld(i+1),
124      &     rad2deg*theta(i),
125      &     rad2deg*phi(i),vbld(nres+i),rad2deg*alph(i),rad2deg*omeg(i)
126       enddo
127       return
128       end
129 c---------------------------------------------------------------------------
130       subroutine briefout(it,ener)
131       implicit real*8 (a-h,o-z)
132       include 'DIMENSIONS'
133       include 'DIMENSIONS.ZSCOPT'
134       include 'COMMON.IOUNITS'
135       include 'COMMON.CHAIN'
136       include 'COMMON.VAR'
137       include 'COMMON.LOCAL'
138       include 'COMMON.INTERACT'
139       include 'COMMON.NAMES'
140       include 'COMMON.GEO'
141       include 'COMMON.SBRIDGE'
142       print '(a,i5)',intname,igeom
143 #if defined(AIX) || defined(PGI)
144       open (igeom,file=intname,position='append')
145 #else
146       open (igeom,file=intname,access='append')
147 #endif
148       IF (NSS.LE.9) THEN
149         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS)
150       ELSE
151         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9)
152         WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS)
153       ENDIF
154 c     IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
155       WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
156       WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES)
157 c     if (nvar.gt.nphi+ntheta) then
158         write (igeom,200) (rad2deg*alph(i),i=2,nres-1)
159         write (igeom,200) (rad2deg*omeg(i),i=2,nres-1)
160 c     endif
161       close(igeom)
162   180 format (I5,F12.3,I2,9(1X,2I3))
163   190 format (3X,11(1X,2I3))
164   200 format (8F10.4)
165       return
166       end