Merge branch 'homology' of mmka.chem.univ.gda.pl:unres into homology
[unres.git] / source / unres / src_MD-M / 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       include 'COMMON.DISTFIT'
11       include 'COMMON.MD'
12       character*50 tytul
13       character*1 chainid(10) /'A','B','C','D','E','F','G','H','I','J'/
14       dimension ica(maxres)
15       write (iunit,'(3a,1pe15.5)') 'REMARK ',tytul,' ENERGY ',etot
16 cmodel      write (iunit,'(a5,i6)') 'MODEL',1
17       if (nhfrag.gt.0) then
18        do j=1,nhfrag
19         iti=itype(hfrag(1,j))
20         itj=itype(hfrag(2,j))
21         if (j.lt.10) then
22            write (iunit,'(a5,i5,1x,a1,i1,2x,a3,i7,2x,a3,i7,i3,t76,i5)') 
23      &           'HELIX',j,'H',j,
24      &           restyp(iti),hfrag(1,j)-1,
25      &           restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j)
26         else
27              write (iunit,'(a5,i5,1x,a1,i2,1x,a3,i7,2x,a3,i7,i3)') 
28      &           'HELIX',j,'H',j,
29      &           restyp(iti),hfrag(1,j)-1,
30      &           restyp(itj),hfrag(2,j)-1,1,hfrag(2,j)-hfrag(1,j)
31         endif
32        enddo
33       endif
34
35       if (nbfrag.gt.0) then
36
37        do j=1,nbfrag
38
39         iti=itype(bfrag(1,j))
40         itj=itype(bfrag(2,j)-1)
41
42         write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3)') 
43      &           'SHEET',1,'B',j,2,
44      &           restyp(iti),bfrag(1,j)-1,
45      &           restyp(itj),bfrag(2,j)-2,0
46
47         if (bfrag(3,j).gt.bfrag(4,j)) then
48
49          itk=itype(bfrag(3,j))
50          itl=itype(bfrag(4,j)+1)
51
52          write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,
53      &              2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') 
54      &           'SHEET',2,'B',j,2,
55      &           restyp(itl),bfrag(4,j),
56      &           restyp(itk),bfrag(3,j)-1,-1,
57      &           "N",restyp(itk),bfrag(3,j)-1,
58      &           "O",restyp(iti),bfrag(1,j)-1
59
60         else
61
62          itk=itype(bfrag(3,j))
63          itl=itype(bfrag(4,j)-1)
64
65
66         write (iunit,'(a5,i5,1x,a1,i1,i3,1x,a3,i6,2x,a3,i6,i3,
67      &              2x,a1,2x,a3,i6,3x,a1,2x,a3,i6)') 
68      &           'SHEET',2,'B',j,2,
69      &           restyp(itk),bfrag(3,j)-1,
70      &           restyp(itl),bfrag(4,j)-2,1,
71      &           "N",restyp(itk),bfrag(3,j)-1,
72      &           "O",restyp(iti),bfrag(1,j)-1
73
74
75
76         endif
77          
78        enddo
79       endif 
80
81       if (nss.gt.0) then
82         do i=1,nss
83          if (dyn_ss) then
84           write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)') 
85      &         'SSBOND',i,'CYS',idssb(i)-nnt+1,
86      &                    'CYS',jdssb(i)-nnt+1
87          else
88           write(iunit,'(a6,i4,1x,a3,i7,4x,a3,i7)') 
89      &         'SSBOND',i,'CYS',ihpb(i)-nnt+1-nres,
90      &                    'CYS',jhpb(i)-nnt+1-nres
91          endif
92         enddo
93       endif
94       
95       iatom=0
96       ichain=1
97       ires=0
98       do i=nnt,nct
99         iti=itype(i)
100         if (iti.eq.21) then
101           ichain=ichain+1
102           ires=0
103           write (iunit,'(a)') 'TER'
104         else
105         ires=ires+1
106         iatom=iatom+1
107         ica(i)=iatom
108         write (iunit,10) iatom,restyp(iti),chainid(ichain),
109      &     ires,(c(j,i),j=1,3),vtot(i)
110         if (iti.ne.10) then
111           iatom=iatom+1
112           write (iunit,20) iatom,restyp(iti),chainid(ichain),
113      &      ires,(c(j,nres+i),j=1,3),
114      &      vtot(i+nres)
115         endif
116         endif
117       enddo
118       write (iunit,'(a)') 'TER'
119       do i=nnt,nct-1
120         if (itype(i).eq.21) cycle
121         if (itype(i).eq.10 .and. itype(i+1).ne.21) then
122           write (iunit,30) ica(i),ica(i+1)
123         else if (itype(i).ne.10 .and. itype(i+1).ne.21) then
124           write (iunit,30) ica(i),ica(i+1),ica(i)+1
125         else if (itype(i).ne.10 .and. itype(i+1).eq.21) then
126           write (iunit,30) ica(i),ica(i)+1
127         endif
128       enddo
129       if (itype(nct).ne.10) then
130         write (iunit,30) ica(nct),ica(nct)+1
131       endif
132       do i=1,nss
133        if (dyn_ss) then
134         write (iunit,30) ica(idssb(i))+1,ica(jdssb(i))+1
135        else
136         write (iunit,30) ica(ihpb(i)-nres)+1,ica(jhpb(i)-nres)+1
137        endif
138       enddo
139       write (iunit,'(a6)') 'ENDMDL'     
140   10  FORMAT ('ATOM',I7,'  CA  ',A3,1X,A1,I4,4X,3F8.3,f15.3)
141   20  FORMAT ('ATOM',I7,'  CB  ',A3,1X,A1,I4,4X,3F8.3,f15.3)
142   30  FORMAT ('CONECT',8I5)
143       return
144       end
145 c------------------------------------------------------------------------------
146       subroutine MOL2out(etot,tytul)
147 C Prints the Cartesian coordinates of the alpha-carbons in the Tripos mol2 
148 C format.
149       implicit real*8 (a-h,o-z)
150       include 'DIMENSIONS'
151       include 'COMMON.CHAIN'
152       include 'COMMON.INTERACT'
153       include 'COMMON.NAMES'
154       include 'COMMON.IOUNITS'
155       include 'COMMON.HEADER'
156       include 'COMMON.SBRIDGE'
157       character*32 tytul,fd
158       character*3 zahl
159       character*6 res_num,pom,ucase
160 #ifdef AIX
161       call fdate_(fd)
162 #elif (defined CRAY)
163       call date(fd)
164 #else
165       call fdate(fd)
166 #endif
167       write (imol2,'(a)') '#'
168       write (imol2,'(a)') 
169      & '#         Creating user name:           unres'
170       write (imol2,'(2a)') '#         Creation time:                ',
171      & fd
172       write (imol2,'(/a)') '\@<TRIPOS>MOLECULE'
173       write (imol2,'(a)') tytul
174       write (imol2,'(5i5)') nct-nnt+1,nct-nnt+nss+1,nct-nnt+nss+1,0,0
175       write (imol2,'(a)') 'SMALL'
176       write (imol2,'(a)') 'USER_CHARGES'
177       write (imol2,'(a)') '\@<TRIPOS>ATOM' 
178       do i=nnt,nct
179         write (zahl,'(i3)') i
180         pom=ucase(restyp(itype(i)))
181         res_num = pom(:3)//zahl(2:)
182         write (imol2,10) i,(c(j,i),j=1,3),i,res_num,0.0
183       enddo
184       write (imol2,'(a)') '\@<TRIPOS>BOND'
185       do i=nnt,nct-1
186         write (imol2,'(i5,2i6,i2)') i-nnt+1,i-nnt+1,i-nnt+2,1
187       enddo
188       do i=1,nss
189         write (imol2,'(i5,2i6,i2)') nct-nnt+i,ihpb(i),jhpb(i),1
190       enddo
191       write (imol2,'(a)') '\@<TRIPOS>SUBSTRUCTURE'
192       do i=nnt,nct
193         write (zahl,'(i3)') i
194         pom = ucase(restyp(itype(i)))
195         res_num = pom(:3)//zahl(2:)
196         write (imol2,30) i-nnt+1,res_num,i-nnt+1,0
197       enddo
198   10  FORMAT (I7,' CA      ',3F10.4,' C.3',I8,1X,A,F11.4,' ****')
199   30  FORMAT (I7,1x,A,I14,' RESIDUE',I13,' ****  ****')
200       return
201       end
202 c------------------------------------------------------------------------
203       subroutine intout
204       implicit real*8 (a-h,o-z)
205       include 'DIMENSIONS'
206       include 'COMMON.IOUNITS'
207       include 'COMMON.CHAIN'
208       include 'COMMON.VAR'
209       include 'COMMON.LOCAL'
210       include 'COMMON.INTERACT'
211       include 'COMMON.NAMES'
212       include 'COMMON.GEO'
213       include 'COMMON.TORSION'
214       write (iout,'(/a)') 'Geometry of the virtual chain.'
215       write (iout,'(7a)') '  Res  ','         d','     Theta',
216      & '       Phi','       Dsc','     Alpha','      Omega'
217       do i=1,nres
218         iti=itype(i)
219         write (iout,'(a3,i4,6f10.3)') restyp(iti),i,vbld(i),
220      &     rad2deg*theta(i),rad2deg*phi(i),vbld(nres+i),rad2deg*alph(i),
221      &     rad2deg*omeg(i)
222       enddo
223       return
224       end
225 c---------------------------------------------------------------------------
226       subroutine briefout(it,ener)
227       implicit real*8 (a-h,o-z)
228       include 'DIMENSIONS'
229       include 'COMMON.IOUNITS'
230       include 'COMMON.CHAIN'
231       include 'COMMON.VAR'
232       include 'COMMON.LOCAL'
233       include 'COMMON.INTERACT'
234       include 'COMMON.NAMES'
235       include 'COMMON.GEO'
236       include 'COMMON.SBRIDGE'
237 c     print '(a,i5)',intname,igeom
238 #if defined(AIX) || defined(PGI)
239       open (igeom,file=intname,position='append')
240 #else
241       open (igeom,file=intname,access='append')
242 #endif
243       IF (NSS.LE.9) THEN
244         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,NSS)
245       ELSE
246         WRITE (igeom,180) IT,ENER,NSS,(IHPB(I),JHPB(I),I=1,9)
247         WRITE (igeom,190) (IHPB(I),JHPB(I),I=10,NSS)
248       ENDIF
249 c     IF (nvar.gt.nphi) WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
250       WRITE (igeom,200) (RAD2DEG*THETA(I),I=3,NRES)
251       WRITE (igeom,200) (RAD2DEG*PHI(I),I=4,NRES)
252 c     if (nvar.gt.nphi+ntheta) then
253         write (igeom,200) (rad2deg*alph(i),i=2,nres-1)
254         write (igeom,200) (rad2deg*omeg(i),i=2,nres-1)
255 c     endif
256       close(igeom)
257   180 format (I5,F12.3,I2,9(1X,2I3))
258   190 format (3X,11(1X,2I3))
259   200 format (8F10.4)
260       return
261       end
262 #ifdef WINIFL
263       subroutine fdate(fd)
264       character*32 fd
265       write(fd,'(32x)')
266       return
267       end
268 #endif
269 c----------------------------------------------------------------
270 #ifdef NOXDR
271       subroutine cartout(time)
272 #else
273       subroutine cartoutx(time)
274 #endif
275       implicit real*8 (a-h,o-z)
276       include 'DIMENSIONS'
277       include 'COMMON.CHAIN'
278       include 'COMMON.INTERACT'
279       include 'COMMON.NAMES'
280       include 'COMMON.IOUNITS'
281       include 'COMMON.HEADER'
282       include 'COMMON.SBRIDGE'
283       include 'COMMON.DISTFIT'
284       include 'COMMON.MD'
285       double precision time
286 #if defined(AIX) || defined(PGI)
287       open(icart,file=cartname,position="append")
288 #else
289       open(icart,file=cartname,access="append")
290 #endif
291       write (icart,'(e15.8,2e15.5,f12.5,$)') time,potE,uconst,t_bath
292       if (dyn_ss) then
293        write (icart,'(i4,$)')
294      &   nss,(idssb(j)+nres,jdssb(j)+nres,j=1,nss)       
295       else
296        write (icart,'(i4,$)')
297      &   nss,(ihpb(j),jhpb(j),j=1,nss)
298        endif
299        write (icart,'(i4,20f7.4)') nfrag+npair+3*nfrag_back,
300      & (qfrag(i),i=1,nfrag),(qpair(i),i=1,npair),
301      & (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back)
302       write (icart,'(8f10.5)')
303      & ((c(k,j),k=1,3),j=1,nres),
304      & ((c(k,j+nres),k=1,3),j=nnt,nct)
305       close(icart)
306       return
307       end
308 c-----------------------------------------------------------------
309 #ifndef NOXDR
310       subroutine cartout(time)
311       implicit real*8 (a-h,o-z)
312       include 'DIMENSIONS'
313 #ifdef MPI
314       include 'mpif.h'
315       include 'COMMON.SETUP'
316 #else
317       parameter (me=0)
318 #endif
319       include 'COMMON.CHAIN'
320       include 'COMMON.INTERACT'
321       include 'COMMON.NAMES'
322       include 'COMMON.IOUNITS'
323       include 'COMMON.HEADER'
324       include 'COMMON.SBRIDGE'
325       include 'COMMON.DISTFIT'
326       include 'COMMON.MD'
327       double precision time
328       integer iret,itmp
329       real xcoord(3,maxres2+2),prec
330
331 #ifdef AIX
332       call xdrfopen_(ixdrf,cartname, "a", iret)
333       call xdrffloat_(ixdrf, real(time), iret)
334       call xdrffloat_(ixdrf, real(potE), iret)
335       call xdrffloat_(ixdrf, real(uconst), iret)
336       call xdrffloat_(ixdrf, real(uconst_back), iret)
337       call xdrffloat_(ixdrf, real(t_bath), iret)
338       call xdrfint_(ixdrf, nss, iret) 
339       do j=1,nss
340        if (dyn_ss) then
341         call xdrfint_(ixdrf, idssb(j)+nres, iret)
342         call xdrfint_(ixdrf, jdssb(j)+nres, iret)
343        else
344         call xdrfint_(ixdrf, ihpb(j), iret)
345         call xdrfint_(ixdrf, jhpb(j), iret)
346        endif
347       enddo
348       call xdrfint_(ixdrf, nfrag+npair+3*nfrag_back, iret)
349       do i=1,nfrag
350         call xdrffloat_(ixdrf, real(qfrag(i)), iret)
351       enddo
352       do i=1,npair
353         call xdrffloat_(ixdrf, real(qpair(i)), iret)
354       enddo
355       do i=1,nfrag_back
356         call xdrffloat_(ixdrf, real(utheta(i)), iret)
357         call xdrffloat_(ixdrf, real(ugamma(i)), iret)
358         call xdrffloat_(ixdrf, real(uscdiff(i)), iret)
359       enddo
360 #else
361       call xdrfopen(ixdrf,cartname, "a", iret)
362       call xdrffloat(ixdrf, real(time), iret)
363       call xdrffloat(ixdrf, real(potE), iret)
364       call xdrffloat(ixdrf, real(uconst), iret)
365       call xdrffloat(ixdrf, real(uconst_back), iret)
366       call xdrffloat(ixdrf, real(t_bath), iret)
367       call xdrfint(ixdrf, nss, iret) 
368       do j=1,nss
369        if (dyn_ss) then
370         call xdrfint(ixdrf, idssb(j)+nres, iret)
371         call xdrfint(ixdrf, jdssb(j)+nres, iret)
372        else
373         call xdrfint(ixdrf, ihpb(j), iret)
374         call xdrfint(ixdrf, jhpb(j), iret)
375        endif
376       enddo
377       call xdrfint(ixdrf, nfrag+npair+3*nfrag_back, iret)
378       do i=1,nfrag
379         call xdrffloat(ixdrf, real(qfrag(i)), iret)
380       enddo
381       do i=1,npair
382         call xdrffloat(ixdrf, real(qpair(i)), iret)
383       enddo
384       do i=1,nfrag_back
385         call xdrffloat(ixdrf, real(utheta(i)), iret)
386         call xdrffloat(ixdrf, real(ugamma(i)), iret)
387         call xdrffloat(ixdrf, real(uscdiff(i)), iret)
388       enddo
389 #endif
390       prec=10000.0
391       do i=1,nres
392        do j=1,3
393         xcoord(j,i)=c(j,i)
394        enddo
395       enddo
396       do i=nnt,nct
397        do j=1,3
398         xcoord(j,nres+i-nnt+1)=c(j,i+nres)
399        enddo
400       enddo
401
402       itmp=nres+nct-nnt+1
403 #ifdef AIX
404       call xdrf3dfcoord_(ixdrf, xcoord, itmp, prec, iret)
405       call xdrfclose_(ixdrf, iret)
406 #else
407       call xdrf3dfcoord(ixdrf, xcoord, itmp, prec, iret)
408       call xdrfclose(ixdrf, iret)
409 #endif
410       return
411       end
412 #endif
413 c-----------------------------------------------------------------
414       subroutine statout(itime)
415       implicit real*8 (a-h,o-z)
416       include 'DIMENSIONS'
417       include 'COMMON.CONTROL'
418       include 'COMMON.CHAIN'
419       include 'COMMON.INTERACT'
420       include 'COMMON.NAMES'
421       include 'COMMON.IOUNITS'
422       include 'COMMON.HEADER'
423       include 'COMMON.SBRIDGE'
424       include 'COMMON.DISTFIT'
425       include 'COMMON.MD'
426       include 'COMMON.SETUP'
427       integer itime
428       double precision energia(0:n_ene)
429       double precision gyrate
430       external gyrate
431       common /gucio/ cm
432       character*256 line1,line2
433       character*4 format1,format2
434       character*30 format
435 #ifdef AIX
436       if(itime.eq.0) then
437        open(istat,file=statname,position="append")
438       endif
439 #else
440 #ifdef PGI
441       open(istat,file=statname,position="append")
442 #else
443       open(istat,file=statname,access="append")
444 #endif
445 #endif
446        if (refstr) then
447          call rms_nac_nnc(rms,frac,frac_nn,co,.false.)
448           write (line1,'(i10,f15.2,3f12.3,f7.2,4f6.3,3f12.3,i5,$)')
449      &          itime,totT,EK,potE,totE,
450      &          rms,frac,frac_nn,co,amax,kinetic_T,t_bath,gyrate(),me
451           format1="a133"
452         else
453           write (line1,'(i10,f15.2,7f12.3,i5,$)')
454      &           itime,totT,EK,potE,totE,
455      &           amax,kinetic_T,t_bath,gyrate(),me
456           format1="a114"
457         endif
458         if(usampl.and.totT.gt.eq_time) then
459            write(line2,'(i5,2f9.4,300f7.4)') iset,uconst,uconst_back,
460      &      (qfrag(ii1),ii1=1,nfrag),(qpair(ii2),ii2=1,npair),
461      &      (utheta(i),ugamma(i),uscdiff(i),i=1,nfrag_back)
462            write(format2,'(a1,i3.3)') "a",23+7*nfrag+7*npair
463      &             +21*nfrag_back
464         else
465            format2="a001"
466            line2=' '
467         endif
468         if (print_compon) then
469           write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2,
470      &                                                     ",20f12.3)"
471           write (istat,format) line1,line2,
472      &      (potEcomp(print_order(i)),i=1,nprint_ene)
473         else
474           write(format,'(a1,a4,a1,a4,a1)') "(",format1,",",format2,")"
475           write (istat,format) line1,line2
476         endif
477 #if defined(AIX)
478         call flush(istat)
479 #else
480         close(istat)
481 #endif
482        return
483       end
484 c---------------------------------------------------------------                      
485       double precision function gyrate()
486       implicit real*8 (a-h,o-z)
487       include 'DIMENSIONS'
488       include 'COMMON.INTERACT'
489       include 'COMMON.CHAIN'
490       double precision cen(3),rg
491
492       do j=1,3
493        cen(j)=0.0d0
494       enddo
495
496       do i=nnt,nct
497           do j=1,3
498             cen(j)=cen(j)+c(j,i)
499           enddo
500       enddo
501       do j=1,3
502             cen(j)=cen(j)/dble(nct-nnt+1)
503       enddo
504       rg = 0.0d0
505       do i = nnt, nct
506         do j=1,3
507          rg = rg + (c(j,i)-cen(j))**2 
508         enddo
509       end do
510       gyrate = sqrt(rg/dble(nct-nnt+1))
511       return
512       end
513