1      subroutine argos_diana_wthdr(fmt,sgmnam,tag,isel,logw)
2c
3c $Id$
4c
5      implicit none
6c
7#include "argos_diana_common.fh"
8c
9      character*16 cwa,sgmnam(msa)
10      integer isel(msa)
11      integer iunit
12      character*3 fmt
13      character*4 cdnum
14      character*255 fname
15      character*24 tag(msa,2)
16      logical logw
17c
18      character*80 label
19c
20      integer i,ib,j,jb,nsb,lq,nwb
21      logical binary
22      character*4 dcdhdr
23      character*80 dcdtit(10)
24      integer*4 icntrl(20),numtit
25c
26      character*1 cdummy
27      character*2 elemnt
28      character*18 name
29c
30      if(me.eq.0) then
31c
32c      if(fmt.eq.'pov') then
33c      if(iunit.eq.lfncop) filpov=filcop
34c      if(iunit.eq.lfnsup) filpov=filsup
35c      npov=0
36c      return
37c      endif
38c
39      binary=fmt(1:1).eq.'b'.or.fmt.eq.'dcd'
40c
41c      if(iunit.eq.lfncop) then
42c      fname=filcop
43c      if(mcopf.gt.0) then
44c      lq=index(filcop,'.')
45c      write(cdnum,'(a1,i3.3)') '_',icopf
46c      fname=filcop(1:lq-1)//cdnum//filcop(lq:index(filcop,' ')-1)
47c      endif
48c
49      if(binary) then
50      open(unit=lfncop,file=filcop(1:index(filcop,' ')-1),
51     + form='unformatted',status='unknown',err=9999)
52      else
53      open(unit=lfncop,file=filcop(1:index(filcop,' ')-1),
54     + form='formatted',status='unknown',err=9999)
55      endif
56      write(*,3333) filcop(1:index(filcop,' ')-1)
57 3333 format(/,' Opening copy file ',a,/)
58c
59c      endif
60c
61c      if(iunit.eq.lfnsup) then
62c      fname=filsup
63c      if(msupf.gt.0) then
64c      lq=index(filsup,'.')
65c      write(cdnum,'(a1,i3.3)') '_',isupf
66c      fname=filsup(1:lq-1)//cdnum//filsup(lq:index(filsup,' ')-1)
67c      endif
68c      if(binary) then
69c      open(unit=lfnsup,file=fname(1:index(fname,' ')-1),
70c     + form='unformatted',status='unknown',err=9999)
71c      else
72c      open(unit=lfnsup,file=fname(1:index(fname,' ')-1),
73c     + form='formatted',status='unknown',err=9999)
74c      endif
75c      write(*,3333) fname(1:index(fname,' ')-1)
76c 3334 format(/,' Opening super file ',a,/)
77c      endif
78c
79c
80      if(fmt.eq.'trj') then
81      write(lfncop,1000)
82 1000 format('header')
83      open(unit=44,file='.header',form='formatted',
84     + status='unknown')
85      rewind(44)
86      read(44,4401) nwa,nsa,nsb,nwb
87      if(logw) then
88      write(lfncop,4401) nwa,nsa,nsb,nwb,nwsel
89      else
90      write(lfncop,4401) nwa,nsa,nsb,nwb,0
91      endif
92 4401 format(5i10)
93      do 1 i=1,nwa
94      read(44,4402) cwa
95 4402 format(a16,i10,i5)
96      write(lfncop,4402) cwa,i
97    1 continue
98      do 2 i=1,nsa
99      read(44,4402) cwa
100      write(lfncop,4402) cwa,i,isel(i)
101    2 continue
102      do 3 i=1,nsb+nwb
103      read(44,4403) ib,jb
104      write(lfncop,4403) ib,jb
105 4403 format(2i8)
106    3 continue
107      close(unit=44)
108      endif
109c
110      if(fmt.eq.'arc') then
111      write(lfncop,2000)
112 2000 format('!BIOSYM archive 3',/,'PBC=OFF')
113      endif
114c
115      if(fmt.eq.'amb') then
116      label='AMBER trajectory file'
117      write(lfncop,3000) label
118 3000 format(a80)
119      endif
120c
121      if(fmt.eq.'crd') then
122      label='AMBER trajectory file'
123      write(lfncop,3000) label
124      endif
125c
126      if(fmt.eq.'bam') then
127      label='AMBER binary trajectory file'
128      write(lfncop) label
129      endif
130c
131      if(fmt.eq.'mvm') then
132      label='ecce mvm trajectory file'
133      write(lfncop,4000) label
134 4000 format('# ',a)
135      write(lfncop,4001)
136 4001 format('type:           molecule')
137      write(lfncop,4002)
138 4002 format('centering:      0')
139      write(lfncop,4003) nsa
140 4003 format('num_atoms:      ',i7)
141      write(lfncop,4004)
142 4004 format('atom_info:      symbol cart')
143      open(unit=44,file='.header',form='formatted',
144     + status='unknown')
145      rewind(44)
146      read(44,4401) nwa,nsa,nsb,nwb
147      do 4 i=1,nwa+nsa
148      read(44,4402) cdummy
149    4 continue
150      write(lfncop,6003) nsb
151 6003 format('num_bonds:      ',i7,/,'bond_list:')
152      do 5 i=1,nsb
153      read(44,4403) ib,jb
154      write(lfncop,4403) ib,jb
155    5 continue
156      close(unit=44)
157      endif
158c
159      if(fmt.eq.'eci') then
160      label='EcceImport 1.1'
161      write(lfncop,5000) label
162 5000 format(a,/,' ')
163      endif
164c
165      if(fmt.eq.'frm') then
166      write(lfncop,6001) nsel
167 6001 format('Atoms {',/,i8)
168      do 6 i=1,nsa
169      if(isel(i).ne.0) then
170      elemnt=sgmnam(i)(6:7)
171      name=sgmnam(i)(11:16)//':'//sgmnam(i)(1:5)//':'//sgmnam(i)(6:10)
172      do 7 j=8,14
173      if(name(j:j).eq.' ') name(j:j)='_'
174    7 continue
175      if(elemnt(1:1).eq.'1'.or.elemnt(1:1).eq.'2'.or.
176     + elemnt(1:1).eq.'3'.or.elemnt(1:1).eq.'4') elemnt(1:1)=' '
177      write(lfncop,6002) elemnt,name,tag(i,1)(1:index(tag(i,1),' ')-1),
178     + tag(i,2)(1:index(tag(i,2),' ')-1)
179 6002 format(a2,1x,a18,1x,a,1x,a)
180      endif
181    6 continue
182      open(unit=44,file='.header',form='formatted',
183     + status='unknown')
184      rewind(44)
185      read(44,4401) nwa,nsa,nsb,nwb
186      do 8 i=1,nwa+nsa
187      read(44,4402) cdummy
188    8 continue
189      if(nsel.eq.nsa) then
190      write(lfncop,6005) nsb
191      else
192      write(lfncop,6005) 0
193      endif
194 6005 format('}',/,'Bonds {',/,i8)
195      if(nsel.eq.nsa) then
196      do 9 i=1,nsb
197      read(44,6006) ib,jb
198      write(lfncop,6006) ib,jb
199 6006 format(2i8)
200    9 continue
201      endif
202      close(unit=44)
203      write(lfncop,6007)
204 6007 format('}')
205      endif
206c
207      if(fmt.eq.'dcd') then
208      dcdhdr='CORD'
209      do 21 i=1,20
210      icntrl(i)=0
211   21 continue
212c     number of frames
213      icntrl(1)=(ifrto-ifrfr+1)/ifrsk
214      icntrl(2)=ifrfr
215      icntrl(3)=1
216      icntrl(4)=ifrto-ifrfr+1
217      icntrl(8)=1
218      icntrl(10)=1026003170
219      icntrl(20)=22
220      write(lfncop) dcdhdr,icntrl
221      dcdtit(1)='charmm dcd formatted trajectory file'
222      numtit=1
223      write(lfncop) numtit,dcdtit(1)
224      ldcd=.false.
225      endif
226c
227      endif
228c
229      return
230c
231 9999 continue
232      call md_abort('Failed to open file',lfncop)
233      return
234      end
235