Merge branch 'multichain' into lipid
[unres.git] / source / xdrfpdb / src / geomout.F
1       subroutine pdbout(etot,tytul,iunit)
2       implicit real*8 (a-h,o-z)
3       include 'DIMENSIONS'
4       include 'COMMON.CHAIN'
5       include 'COMMON.INTERACT'
6       include 'COMMON.NAMES'
7       include 'COMMON.IOUNITS'
8       include 'COMMON.HEADER'
9       include 'COMMON.SBRIDGE'
10 c      include 'COMMON.DISTFIT'
11 c      include 'COMMON.MD'
12       character*50 tytul
13       dimension ica(maxres)
14       write (iunit,'(3a,1pe15.5)') 'REMARK ',tytul,' ENERGY ',etot
15 cmodel      write (iunit,'(a5,i6)') 'MODEL',1
16 c      if (nhfrag.gt.0) then
17 c       do j=1,nhfrag
18 c        iti=itype(hfrag(1,j))
19 c        itj=itype(hfrag(2,j))
20 c        if (j.lt.10) then
21 c           write (iunit,'(a5,i5,1x,a1,i1,2x,a3,i7,2x,a3,i7,i3,t76,i5)') 
22 c     &           'HELIX',j,'H',j,
23 c     &           restyp(iti),hfrag(1,j)-1,
24 c     &           restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j)
25 c        else
26 c             write (iunit,'(a5,i5,1x,a1,i2,1x,a3,i7,2x,a3,i7,i3)') 
27 c     &           'HELIX',j,'H',j,
28 c     &           restyp(iti),hfrag(1,j)-1,
29 c     &           restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j)
30 c        endif
31 c       enddo
32 c      endif
33
34 c      if (nbfrag.gt.0) then
35 c
36 c       do j=1,nbfrag
37 c
38 c        iti=itype(bfrag(1,j))
39 c        itj=itype(bfrag(2,j)-1)
40 c
41 c        write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3)') 
42 c     &           'SHEET',1,'B',j,2,
43 c     &           restyp(iti),bfrag(1,j)-1,
44 c     &           restyp(itj),bfrag(2,j)-2,0
45 c
46 c        if (bfrag(3,j).gt.bfrag(4,j)) then
47 c
48 c         itk=itype(bfrag(3,j))
49 c         itl=itype(bfrag(4,j)+1)
50 c
51 c         write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,
52 c     &              2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') 
53 c     &           'SHEET',2,'B',j,2,
54 c     &           restyp(itl),bfrag(4,j),
55 c     &           restyp(itk),bfrag(3,j)-1,-1,
56 c     &           "N",restyp(itk),bfrag(3,j)-1,
57 c     &           "O",restyp(iti),bfrag(1,j)-1
58 c
59 c        else
60 c
61 c         itk=itype(bfrag(3,j))
62 c         itl=itype(bfrag(4,j)-1)
63 c
64 c
65 c        write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,
66 c     &              2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') 
67 c     &           'SHEET',2,'B',j,2,
68 c     &           restyp(itk),bfrag(3,j)-1,
69 c     &           restyp(itl),bfrag(4,j)-2,1,
70 c     &           "N",restyp(itk),bfrag(3,j)-1,
71 c     &           "O",restyp(iti),bfrag(1,j)-1
72 c
73 c
74 c
75 c        endif
76 c         
77 c       enddo
78 c      endif 
79
80       if (nss.gt.0) then
81         do i=1,nss
82           write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)') 
83      &         'SSBOND',i,'CYS',ihpb(i)-1-nres,
84      &                    'CYS',jhpb(i)-1-nres
85         enddo
86       endif
87       
88       iatom=0
89       do i=nnt,nct
90         ires=i-nnt+1
91         iatom=iatom+1
92         ica(i)=iatom
93         iti=itype(i)
94         write (iunit,10) iatom,restyp(iti),ires,(c(j,i),j=1,3)!,vtot(i)
95         if (iti.ne.10) then
96           iatom=iatom+1
97           write (iunit,20) iatom,restyp(iti),ires,(c(j,nres+i),j=1,3)!,
98 !     &      vtot(i+nres)
99         endif
100       enddo
101       write (iunit,'(a)') 'TER'
102       do i=nnt,nct-1
103         if (itype(i).eq.10) then
104           write (iunit,30) ica(i),ica(i+1)
105         else
106           write (iunit,30) ica(i),ica(i+1),ica(i)+1
107         endif
108       enddo
109       if (itype(nct).ne.10) then
110         write (iunit,30) ica(nct),ica(nct)+1
111       endif
112       do i=1,nss
113         write (iunit,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1
114       enddo
115       write (iunit,'(a6)') 'ENDMDL'     
116   10  FORMAT ('ATOM',I7,'  CA  ',A3,I6,4X,3F8.3,f15.3)
117   20  FORMAT ('ATOM',I7,'  CB  ',A3,I6,4X,3F8.3,f15.3)
118   30  FORMAT ('CONECT',8I5)
119       return
120       end
121 c------------------------------------------------------------------------------
122       subroutine MOL2out(etot,tytul)
123 C Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2 
124 C format.
125       implicit real*8 (a-h,o-z)
126       include 'DIMENSIONS'
127       include 'COMMON.CHAIN'
128       include 'COMMON.INTERACT'
129       include 'COMMON.NAMES'
130       include 'COMMON.IOUNITS'
131       include 'COMMON.HEADER'
132       include 'COMMON.SBRIDGE'
133       character*32 tytul,fd
134       character*3 liczba
135       character*6 res_num,pom,ucase
136 #ifdef AIX
137       call fdate_(fd)
138 #elif (defined CRAY)
139       call date(fd)
140 #else
141       call fdate(fd)
142 #endif
143       write (imol2,'(a)') '#'
144       write (imol2,'(a)') 
145      & '#         Creating user name:           unres'
146       write (imol2,'(2a)') '#         Creation time:                ',
147      & fd
148       write (imol2,'(/a)') '\@<TRIPOS>MOLECULE'
149       write (imol2,'(a)') tytul
150       write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0
151       write (imol2,'(a)') 'SMALL'
152       write (imol2,'(a)') 'USER_CHARGES'
153       write (imol2,'(a)') '\@<TRIPOS>ATOM' 
154       do i=nnt,nct
155         write (liczba,'(i3)') i
156         pom=ucase(restyp(itype(i)))
157         res_num = pom(:3)//liczba(2:)
158         write (imol2,10) i,(c(j,i),j=1,3),i,res_num,0.0
159       enddo
160       write (imol2,'(a)') '\@<TRIPOS>BOND'
161       do i=nnt,nct-1
162         write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1
163       enddo
164       do i=1,nss
165         write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1
166       enddo
167       write (imol2,'(a)') '\@<TRIPOS>SUBSTRUCTURE'
168       do i=nnt,nct
169         write (liczba,'(i3)') i
170         pom = ucase(restyp(itype(i)))
171         res_num = pom(:3)//liczba(2:)
172         write (imol2,30) i-nnt+1,res_num,i-nnt+1,0
173       enddo
174   10  FORMAT (I7,' CA      ',3F10.4,' C.3',I8,1X,A,F11.4,' ****')
175   30  FORMAT (I7,1x,A,I14,' RESIDUE',I13,' ****  ****')
176       return
177       end
178 c------------------------------------------------------------------------
179       subroutine briefout(it,ener)
180       implicit real*8 (a-h,o-z)
181       include 'DIMENSIONS'
182       include 'COMMON.IOUNITS'
183       include 'COMMON.CHAIN'
184       include 'COMMON.VAR'
185       include 'COMMON.LOCAL'
186       include 'COMMON.INTERACT'
187       include 'COMMON.NAMES'
188       include 'COMMON.GEO'
189       include 'COMMON.SBRIDGE'
190 c     print '(a,i5)',intname,igeom
191 #if defined(AIX) || defined(PGI)
192       open (igeom,file=intname,position='append')
193 #else
194       open (igeom,file=intname,access='append')
195 #endif
196       IF (NSS.LE.9) THEN
197         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS)
198       ELSE
199         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9)
200         WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS)
201       ENDIF
202 c     IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
203       WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
204       WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES)
205 c     if (nvar.gt.nphi+ntheta) then
206         write (igeom,200) (rad2deg*alph(i),i=2,nres-1)
207         write (igeom,200) (rad2deg*omeg(i),i=2,nres-1)
208 c     endif
209       close(igeom)
210   180 format (I5,F12.3,I2,9(1X,2I3))
211   190 format (3X,11(1X,2I3))
212   200 format (8F10.4)
213       return
214       end
215 #ifdef WINIFL
216       subroutine fdate(fd)
217       character*32 fd
218       write(fd,'(32x)')
219       return
220       end
221 #endif
222 c----------------------------------------------------------------
223       subroutine cartoutx(time,nfrag,qfrag)
224       implicit real*8 (a-h,o-z)
225       include 'DIMENSIONS'
226       include 'COMMON.CHAIN'
227       include 'COMMON.INTERACT'
228       include 'COMMON.NAMES'
229       include 'COMMON.IOUNITS'
230       include 'COMMON.HEADER'
231       include 'COMMON.SBRIDGE'
232       include 'COMMON.DISTFIT'
233 c      include 'COMMON.MD'
234       double precision time
235       double precision qfrag(100)
236 #if defined(AIX) || defined(PGI)
237       open(icart,file=cartname,position="append")
238 #else
239       open(icart,file=cartname,access="append")
240 #endif
241       write (icart,'(e15.8,2e15.5,f12.5,$)') time,potE,uconst,t_bath
242       write (icart,'(i4,$)')
243      &   nss,(ihpb(j),jhpb(j),j=1,nss)
244        write (icart,'(i4,20f7.4)') nfrag,
245      & (qfrag(i),i=1,nfrag)
246       write (icart,'(8f10.5)')
247      & ((c(k,j),k=1,3),j=1,nres),
248      & ((c(k,j+nres),k=1,3),j=nnt,nct)
249       close(icart)
250       return
251       end
252 c-----------------------------------------------------------------
253       subroutine cartout(time,nfrag,qfrag)
254       implicit real*8 (a-h,o-z)
255       include 'DIMENSIONS'
256       include 'COMMON.CHAIN'
257       include 'COMMON.INTERACT'
258       include 'COMMON.NAMES'
259       include 'COMMON.IOUNITS'
260       include 'COMMON.HEADER'
261       include 'COMMON.SBRIDGE'
262       include 'COMMON.DISTFIT'
263 c      include 'COMMON.MD'
264       double precision time
265       integer iret,itmp
266       double precision qfrag(100)
267       real xcoord(3,maxres2+2),prec
268
269       call xdrfopen(ixdrf,cartname, "w", iret)
270       call xdrffloat(ixdrf, real(time), iret)
271       call xdrffloat(ixdrf, real(potE), iret)
272       call xdrffloat(ixdrf, real(uconst), iret)
273       call xdrffloat(ixdrf, real(t_bath), iret)
274       call xdrfint(ixdrf, nss, iret) 
275       do j=1,nss
276         call xdrfint(ixdrf, ihpb(j), iret)
277         call xdrfint(ixdrf, jhpb(j), iret)
278       enddo
279       call xdrfint(ixdrf, nfrag, iret)
280       do i=1,nfrag
281         call xdrffloat(ixdrf, real(qfrag(i)), iret)
282       enddo
283       prec=10000.0
284       do i=1,nres
285        do j=1,3
286         xcoord(j,i)=c(j,i)
287        enddo
288       enddo
289       do i=nnt,nct
290        do j=1,3
291         xcoord(j,nres+i-nnt+1)=c(j,i+nres)
292        enddo
293       enddo
294
295       itmp=nres+nct-nnt+1
296       call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret)
297       call xdrfclose(ixdrf, iret)
298       return
299       end