D i L aminokwasy dzialajace dla src_CSA
[unres.git] / source / unres / src_CSA_DiL / geomout_min.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       include 'COMMON.DISTFIT'
11       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       if (nhfrag.gt.0) then
17        do j=1,nhfrag
18         iti=itype(hfrag(1,j))
19         itj=itype(hfrag(2,j))
20         if (j.lt.10) then
21            write (iunit,'(a5,i5,1x,a1,i1,2x,a3,i7,2x,a3,i7,i3,t76,i5)') 
22      &           'HELIX',j,'H',j,
23      &           restyp(iti),hfrag(1,j)-1,
24      &           restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j)
25         else
26              write (iunit,'(a5,i5,1x,a1,i2,1x,a3,i7,2x,a3,i7,i3)') 
27      &           'HELIX',j,'H',j,
28      &           restyp(iti),hfrag(1,j)-1,
29      &           restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j)
30         endif
31        enddo
32       endif
33
34       if (nbfrag.gt.0) then
35
36        do j=1,nbfrag
37
38         iti=itype(bfrag(1,j))
39         itj=itype(bfrag(2,j)-1)
40
41         write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3)') 
42      &           'SHEET',1,'B',j,2,
43      &           restyp(iti),bfrag(1,j)-1,
44      &           restyp(itj),bfrag(2,j)-2,0
45
46         if (bfrag(3,j).gt.bfrag(4,j)) then
47
48          itk=itype(bfrag(3,j))
49          itl=itype(bfrag(4,j)+1)
50
51          write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,
52      &              2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') 
53      &           'SHEET',2,'B',j,2,
54      &           restyp(itl),bfrag(4,j),
55      &           restyp(itk),bfrag(3,j)-1,-1,
56      &           "N",restyp(itk),bfrag(3,j)-1,
57      &           "O",restyp(iti),bfrag(1,j)-1
58
59         else
60
61          itk=itype(bfrag(3,j))
62          itl=itype(bfrag(4,j)-1)
63
64
65         write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,
66      &              2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') 
67      &           'SHEET',2,'B',j,2,
68      &           restyp(itk),bfrag(3,j)-1,
69      &           restyp(itl),bfrag(4,j)-2,1,
70      &           "N",restyp(itk),bfrag(3,j)-1,
71      &           "O",restyp(iti),bfrag(1,j)-1
72
73
74
75         endif
76          
77        enddo
78       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*50 tytul,fd
134       character*3 zahl
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 (zahl,'(i3)') i
156         pom=ucase(restyp(itype(i)))
157         res_num = pom(:3)//zahl(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 (zahl,'(i3)') i
170         pom = ucase(restyp(itype(i)))
171         res_num = pom(:3)//zahl(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 intout
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       write (iout,'(/a)') 'Geometry of the virtual chain.'
190       write (iout,'(7a)') '  Res  ','         d','     Theta',
191      & '     Gamma','       Dsc','     Alpha','      Beta '
192       do i=1,nres
193         iti=itype(i)
194         write (iout,'(a3,i4,6f10.3)') restyp(iti),i,vbld(i),
195      &     rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i),rad2deg*alph(i),
196      &     rad2deg*omeg(i)
197       enddo
198       return
199       end
200 c---------------------------------------------------------------------------
201       subroutine briefout(it,ener)
202       implicit real*8 (a-h,o-z)
203       include 'DIMENSIONS'
204       include 'COMMON.IOUNITS'
205       include 'COMMON.CHAIN'
206       include 'COMMON.VAR'
207       include 'COMMON.LOCAL'
208       include 'COMMON.INTERACT'
209       include 'COMMON.NAMES'
210       include 'COMMON.GEO'
211       include 'COMMON.SBRIDGE'
212 c     print '(a,i5)',intname,igeom
213 #if defined(AIX) || defined(PGI)
214       open (igeom,file=intname,position='append')
215 #else
216       open (igeom,file=intname,access='append')
217 #endif
218       IF (NSS.LE.9) THEN
219         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS)
220       ELSE
221         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9)
222         WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS)
223       ENDIF
224 c     IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
225       WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
226       WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES)
227 c     if (nvar.gt.nphi+ntheta) then
228         write (igeom,200) (rad2deg*alph(i),i=2,nres-1)
229         write (igeom,200) (rad2deg*omeg(i),i=2,nres-1)
230 c     endif
231       close(igeom)
232   180 format (I5,F12.3,I2,9(1X,2I3))
233   190 format (3X,11(1X,2I3))
234   200 format (8F10.4)
235       return
236       end
237 #ifdef WINIFL
238       subroutine fdate(fd)
239       character*32 fd
240       write(fd,'(32x)')
241       return
242       end
243 #endif
244 c-----------------------------------------------------------------
245       subroutine statout(itime)
246       implicit real*8 (a-h,o-z)
247       include 'DIMENSIONS'
248       include 'COMMON.CONTROL'
249       include 'COMMON.CHAIN'
250       include 'COMMON.INTERACT'
251       include 'COMMON.NAMES'
252       include 'COMMON.IOUNITS'
253       include 'COMMON.HEADER'
254       include 'COMMON.SBRIDGE'
255       include 'COMMON.DISTFIT'
256       include 'COMMON.MD_'
257 c      include 'COMMON.REMD'
258       include 'COMMON.SETUP'
259       integer itime
260       double precision energia(0:n_ene)
261       double precision gyrate
262       external gyrate
263       common /gucio/ cm
264       character*256 line1,line2
265       character*4 format1,format2
266       character*30 format
267 #ifdef AIX
268       if(itime.eq.0) then
269        open(istat,file=statname,position="append")
270       endif
271 #else
272 #ifdef PGI
273       open(istat,file=statname,position="append")
274 #else
275       open(istat,file=statname,access="append")
276 #endif
277 #endif
278        if (refstr) then
279 c         call rms_nac_nnc(rms,frac,frac_nn,co,.false.)
280           write (line1,'(i10,f15.2,3f12.3,f7.2,4f6.3,3f12.3,i5,$)')
281      &          itime,totT,EK,potE,totE,
282      &          rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me
283           format1="a133"
284         else
285           write (line1,'(i10,f15.2,7f12.3,i5,$)')
286      &           itime,totT,EK,potE,totE,
287      &           amax,kinetic_T,t_bath,gyrate(),me
288           format1="a114"
289         endif
290         if(usampl.and.totT.gt.eq_time) then
291            write(line2,'(i5,2f9.4,300f7.4)') iset,uconst,uconst_back,
292      &      (qfrag(ii1),ii1=1,nfrag),(qpair(ii2),ii2=1,npair),
293      &      (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back)
294            write(format2,'(a1,i3.3)') "a",23+7*nfrag+7*npair
295      &             +21*nfrag_back
296         elseif(hremd.gt.0) then
297            write(line2,'(i5)') iset
298            format2="a005"
299         else
300            format2="a001"
301            line2=' '
302         endif
303         if (print_compon) then
304           write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2,
305      &                                                     ",20f12.3)"
306           write (istat,format) line1,line2,
307      &      (potEcomp(print_order(i)),i=1,nprint_ene)
308         else
309           write(format,'(a1,a4,a1,a4,a1)') "(",format1,",",format2,")"
310           write (istat,format) line1,line2
311         endif
312 #if defined(AIX)
313         call flush(istat)
314 #else
315         close(istat)
316 #endif
317        return
318       end
319 c---------------------------------------------------------------                      
320       double precision function gyrate()
321       implicit real*8 (a-h,o-z)
322       include 'DIMENSIONS'
323       include 'COMMON.INTERACT'
324       include 'COMMON.CHAIN'
325       double precision cen(3),rg
326
327       do j=1,3
328        cen(j)=0.0d0
329       enddo
330
331       do i=nnt,nct
332           do j=1,3
333             cen(j)=cen(j)+c(j,i)
334           enddo
335       enddo
336       do j=1,3
337             cen(j)=cen(j)/dble(nct-nnt+1)
338       enddo
339       rg = 0.0d0
340       do i = nnt, nct
341         do j=1,3
342          rg = rg + (c(j,i)-cen(j))**2 
343         enddo
344       end do
345       gyrate = sqrt(rg/dble(nct-nnt+1))
346       return
347       end
348