Line data Source code
1 1 : subroutine ofiles
2 : c
3 : c reads unit numbers and file names from standard input, in
4 : c format
5 : c
6 : c <unit number> <file name>
7 : c
8 : c if file name is given as 0, /dev/null is used for the file.
9 : c input ends with EOF or a line containing -1.
10 : c returns number of files in nfiles, unit numbers in ids(.),
11 : c and file names in file(.).
12 : c
13 : c 19/8/87: modified for HP9000 by taking out action option
14 : c in s/r openf.
15 : c
16 : c 21/8/87: modified for HP9000 by replacing multiple occurrences
17 : c of /dev/null by scratch files, since the HP9000, unfortunately,
18 : c does not allow several unit numbers to be associated with
19 : c /dev/null
20 : c
21 : c 4/5/95: Add s/r openfs, which opens file and stores information
22 : c in common /cofile/
23 : c
24 : c 9/9/96: Add array iopen as flag for files being actually open.
25 : c iopen(n) = 1 or 2 for normal file (iopen(n) = 2 is used to
26 : c flag for newly opened file).
27 : c iopen(n) = -1 for scratch file
28 : c
29 : c 14/10/04: Add option to add trailer to file name (mainly for
30 : c iteration with evolution code, etc.). The trailer must be
31 : c set in common/trl_param/ and is added in s/r openf if
32 : c status is `nt', `ut' or `ot'
33 : c
34 : c 21/10/04: Add s/r newfil to test whether the file has been newly
35 : c opened, by testing the value of the relevant iopen(k). AFter
36 : c call of newfil iopen is reset to flag for old file.
37 : c
38 : c 17/3/05: Include istdin for standard input
39 : c
40 : c Modified 19/12/07, increasing number of files from 20 to 99
41 : c ..............................................
42 : c
43 : character*280 file, filein, filess
44 : common/cofile/ nfiles, ids(99), file(99), iopen(99), filess(99)
45 : c
46 : c nfiles and iopen initialized in block data blopen below
47 : c
48 : c common defining standard input and output
49 : c
50 : common/cstdio/ istdin, istdou, istdpr, istder
51 : c
52 : c the following line required on CR32
53 : c
54 : c.. save nfiles, ids, file
55 : c
56 1 : write(istdou,*) 'Input format: <unit number> <file name>'
57 1 : write(istdou,*) 'input ends with EOF or a line containing -1.'
58 : write(istdou,*)
59 1 : * 'if file name is given as 0, /dev/null is used for the file.'
60 : c
61 6 : 10 read(istdin,*, end=30) idsin, filein
62 6 : if(idsin.lt.0) go to 30
63 : c
64 : c test for /dev/null
65 : c
66 5 : if(filein.eq.'0') then
67 0 : filein='/dev/null'
68 : end if
69 : c
70 5 : nfiles=nfiles+1
71 5 : ids(nfiles)=idsin
72 5 : file(nfiles)=filein
73 5 : go to 10
74 : c
75 : 30 continue
76 : c
77 : c output file information
78 : c
79 1 : write(istdou,100)
80 6 : do 40 n=1,nfiles
81 6 : 40 write(istdou,110) ids(n),file(n)
82 1 : write(istdou,120)
83 1 : return
84 : 100 format(/' files set in s/r ofiles:'/)
85 : 110 format(i3,2x,'''',a,''' @')
86 : 120 format('-1 '''' @')
87 : end
88 148 : subroutine stfile(idsst, nfst)
89 : c
90 : c find number of file nfst corresponding to unit number idsst.
91 : c list of unit numbers and file names in ids and file must have been
92 : c set up in common/cofile/ by call of ofiles.
93 : c
94 : character*280 file, filein, filess
95 : common/cofile/ nfiles, ids(99), file(99), iopen(99), filess(99)
96 : c
97 : c common defining standard input and output
98 : c
99 : common/cstdio/ istdin, istdou, istdpr, istder
100 : c
101 : c the following line required on CR32
102 : c
103 : c.. save nfiles, ids, file
104 : c
105 626 : do 10 i=1,nfiles
106 579 : if(idsst.eq.ids(i)) then
107 101 : nfst=i
108 101 : go to 20
109 : end if
110 47 : 10 continue
111 : c
112 : c idsst not found, print diagnostics
113 : c
114 : write(istdou,'(/i4,'' not found''//
115 47 : * '' List of files available:'')') idsst
116 282 : do 15 i=1,nfiles
117 235 : lfile=length(file(i))
118 282 : 15 write(istdou,'(i4,3x,a)') ids(i),file(i)(1:lfile)
119 : c
120 47 : nfst=-1
121 : c
122 : 20 continue
123 148 : return
124 : end
125 0 : subroutine addfil(idsnew, new_file)
126 : c
127 : c Adds file file_name to list of files set by ofiles.
128 : c If unit number ids already exists, replaces file name,
129 : c otherwise adds to list of unit numbers.
130 : c
131 : c Original version: 11/2/06
132 : c
133 : character*(*) new_file
134 : character*280 file, filein, filess
135 : common/cofile/ nfiles, ids(99), file(99), iopen(99), filess(99)
136 : c
137 : c common defining standard input and output
138 : c
139 : common/cstdio/ istdin, istdou, istdpr, istder
140 : c
141 0 : do 10 i=1,nfiles
142 0 : if(idsnew.eq.ids(i)) then
143 0 : nfst=i
144 0 : go to 20
145 : end if
146 0 : 10 continue
147 : c
148 : c ids not found, add number to list
149 : c
150 0 : if(istdpr.gt.0) write(istdpr,'(/'' File number '', i3,
151 0 : * '' added to list''/)') idsnew
152 : c
153 0 : nfiles=nfiles+1
154 0 : nfst=nfiles
155 0 : ids(nfst)=idsnew
156 : c
157 : 20 continue
158 : c
159 0 : file(nfst)=new_file
160 0 : if(istdpr.gt.0) write(istdpr,'(/'' New unit, file:'',
161 0 : * i3,2x,a/)') ids(nfst), file(nfst)
162 0 : iopen(nfst)=0
163 0 : return
164 0 : end
165 0 : logical function opnfil(idsst)
166 : c
167 : c Returns .true. if file has been opened, false otherwise.
168 : c Diagnostics are returned depending on the hard-coded idiag
169 : c
170 : c Original version: 3/8/05
171 : c
172 : character*280 file, filein, filess
173 : common/cofile/ nfiles, ids(99), file(99), iopen(99), filess(99)
174 : c
175 : c common defining standard input and output
176 : c
177 : common/cstdio/ istdin, istdou, istdpr, istder
178 : c
179 : c the following line required on CR32
180 : c
181 : c.. save nfiles, ids, file
182 : c
183 0 : idiag=0
184 : c
185 0 : nfst=-1
186 0 : do 10 i=1,nfiles
187 0 : if(idsst.eq.ids(i)) then
188 0 : nfst=i
189 : end if
190 0 : 10 continue
191 : c
192 : c idsst not found, print diagnostics
193 : c
194 0 : if(idiag.gt.0.and.istdpr.gt.0) then
195 0 : write(istdpr,*) idsst,' not found'
196 0 : write(istdpr,*) 'List of files available:'
197 0 : do 15 i=1,nfiles
198 0 : 15 write(istdpr,*) ids(i),' ',file(i)
199 : end if
200 : c
201 0 : opnfil=nfst.ne.-1
202 : c
203 0 : return
204 : end
205 138 : logical function nscfil(idsst)
206 : c
207 : c returns true if file corresponding to unit number idsst
208 : c is not a scratch file, false otherwise, including if the
209 : c unit number has not been set or is negative.
210 : c
211 : character*280 file, filein, filess
212 : common/cofile/ nfiles, ids(99), file(99), iopen(99), filess(99)
213 : c
214 : c common defining standard input and output
215 : c
216 : common/cstdio/ istdin, istdou, istdpr, istder
217 : c
218 138 : if(idsst.le.0) then
219 0 : nscfil=.false.
220 : else
221 138 : call stfile(idsst, nfst)
222 : c.. if(istdpr.gt.0)
223 : c.. * write(istdpr,*) 'In nscfil, idsst, nfst, iopen(nfst) =',
224 : c.. * idsst, nfst, iopen(nfst)
225 138 : if(nfst.eq.-1) then
226 46 : nscfil=.false.
227 : else
228 92 : nscfil = iopen(nfst).gt.0
229 : end if
230 : end if
231 138 : return
232 : end
233 0 : logical function newfil(idsst)
234 : c
235 : c returns true if file corresponding to unit number idsst
236 : c is newly opened and not a scratch file and resets relevant iopen
237 : c to flag file as old.
238 : c
239 : character*280 file, filein, filess
240 : common/cofile/ nfiles, ids(99), file(99), iopen(99), filess(99)
241 : c
242 : c common defining standard input and output
243 : c
244 : common/cstdio/ istdin, istdou, istdpr, istder
245 : c
246 0 : if(idsst.le.0) then
247 0 : newfil=.false.
248 : else
249 0 : call stfile(idsst, nfst)
250 : c.. if(istdpr.gt.0)
251 : c.. * write(istdpr,*) 'In newfil, idsst, nfst, iopen(nfst) =',
252 : c.. * idsst, nfst, iopen(nfst)
253 0 : if(nfst.eq.-1) then
254 0 : newfil=.false.
255 : else
256 0 : if(iopen(nfst).lt.0) then
257 0 : newfil=.false.
258 : else
259 0 : newfil = iopen(nfst).gt.1
260 0 : iopen(nfst) = 1
261 : end if
262 : end if
263 : end if
264 0 : return
265 : end
266 5 : subroutine openf(id,status,form)
267 : c
268 : c open file with unit number id, status as in string status,
269 : c and format as in string form.
270 : c status and form may be abbreviated to a single character,
271 : c as i.e.'n' for 'new', 'u' for 'unformatted'.
272 : c
273 : c s/r ofiles must have been called previously to set up
274 : c nfiles, ids and file in common /cofile/.
275 : c
276 : c original version 30/9/86
277 : c
278 : c ....................................
279 : c
280 : character*(*) status, form
281 : character*280 stat1, form1, file, files, trailer_par, filess,
282 : * strcompr
283 : character*24 fdate
284 : character ss1*1, ss2*2, stime*10
285 : !integer time
286 : common/cofile/ nfiles, ids(99), file(99), iopen(99), filess(99)
287 : common/trl_param/ trailer_par
288 : c
289 : c common defining standard input and output
290 : c
291 : common/cstdio/ istdin, istdou, istdpr, istder
292 : !external time
293 : data trailer_par /''/
294 : c
295 : save
296 : data nnul /0/
297 : c
298 : c find file name
299 : c
300 5 : call stfile(id,nfin)
301 5 : if(nfin.lt.0) go to 90
302 : c
303 : c set full status
304 : c
305 5 : if(status(1:1).eq.'o') then
306 2 : stat1='old'
307 3 : else if(status(1:1).eq.'n') then
308 0 : stat1='new'
309 3 : else if(status(1:1).eq.'s') then
310 0 : stat1='scratch'
311 : else
312 3 : stat1='unknown'
313 : end if
314 : c
315 : c for /dev/null, set status to old
316 : c
317 5 : if(file(nfin).eq.'/dev/null') then
318 0 : nnul = min(9,nnul+1)
319 : c.. if(istdpr.gt.0) write(istdpr,*) 'Now nnul =',nnul
320 0 : if(nnul.eq.1) then
321 0 : stat1='old'
322 : else
323 0 : stat1='scratch'
324 : end if
325 : end if
326 : c
327 : c set full format
328 : c
329 5 : if(form(1:1).eq.'u') then
330 4 : form1='unformatted'
331 : else
332 1 : form1='formatted'
333 : end if
334 : c
335 : c open file, if not already open
336 : c
337 5 : if(stat1.eq.'scratch') then
338 0 : write(ss1,'(i1)') nnul
339 0 : call system_clock(itime)
340 : !itime = time()
341 0 : write(stime,'(i10)') itime
342 : c.. files='scratch/ttt.'//fdate()//'.'//ss1
343 : c.. files=strcompr(files)
344 0 : files='scratch/ttt.'//stime//'.'//ss1
345 0 : if(iopen(nfin).eq.-1) then
346 0 : write(istdou,'(2a)') 'Scratch file already open: ',
347 0 : * filess(nfin)
348 : else
349 0 : write(istdou,'(2a)') 'Scratch file: ',files
350 0 : open(id,status='unknown',file=files, form=form1)
351 0 : iopen(nfin)=-1
352 0 : filess(nfin)=files
353 : end if
354 : c
355 : c diagnostic output
356 : c
357 0 : if(istdpr.gt.0) write(istdpr,110) id,stat1,form1
358 : c
359 : else
360 5 : if(status(1:2).eq.'ut'.or.status(1:2).eq.'nt'.or.
361 : * status(1:2).eq.'ot') then
362 0 : files=file(nfin)
363 0 : if(files.ne.'/dev/null') then
364 : files=
365 0 : * files(1:length(files))//trailer_par(1:length(trailer_par))
366 : end if
367 : c.. write(6,*) ' Set files to ',files
368 : else
369 5 : files=file(nfin)
370 : c.. write(6,*) ' Set files to ',files
371 : end if
372 5 : open(id,file=files,status=stat1,form=form1)
373 5 : iopen(nfin)=2
374 : c
375 5 : filess(nfin)=files
376 : c
377 : c diagnostic output
378 : c
379 5 : if(istdpr.gt.0) write(istdpr,100) id,files,stat1,form1
380 : c
381 : end if
382 : c
383 5 : return
384 : c
385 : c error in locating file name. exit
386 : c
387 0 : 90 stop
388 : 100 format(' open(',i3,',file=',a30,',status=',a10,',form=',a10,')')
389 : 110 format(' open(',i3,',status=',a,',form=',a,')')
390 5 : end
391 3 : subroutine openfc(id,idp,status,form)
392 : c
393 : c open file with unit number id, status as in string status,
394 : c format as in string form. For details, see s/r openf.
395 : c
396 : c open only takes place if id .ne. idp or trailer_par has been
397 : c changed. If idp .gt. 0, also closes unit idp.
398 : c idp is returned as id.
399 : c
400 : logical newfile
401 : character*(*) status, form
402 : character*280 stat1, form1, file, files, filess, trailer_par
403 : common/cofile/ nfiles, ids(99), file(99), iopen(99), filess(99)
404 : common/trl_param/ trailer_par
405 : c
406 : save
407 : c
408 3 : newfile=.false.
409 : c
410 : c find file name
411 : c
412 3 : call stfile(id,nfin)
413 3 : if(nfin.lt.0) go to 90
414 3 : if(status(1:2).eq.'ut'.or.status(1:2).eq.'nt'.or.
415 : * status(1:2).eq.'ot') then
416 0 : files=file(nfin)
417 0 : if(files.ne.'/dev/null') files=
418 0 : * files(1:length(files))//trailer_par(1:length(trailer_par))
419 : c.. write(6,*) files
420 : c.. write(6,*) filess(nfin)
421 0 : newfile=files.ne.filess(nfin)
422 : end if
423 : c
424 3 : newfile=newfile.or.(id.ne.idp)
425 3 : if(newfile) then
426 3 : if(idp.gt.0) close(idp)
427 3 : call openf(id,status,form)
428 3 : idp=id
429 : end if
430 : c
431 3 : return
432 : c
433 0 : 90 stop 'Error in openfc'
434 3 : end
435 0 : subroutine openfs(id,fn,status,form)
436 : c
437 : c open file with unit number id, filename fn,
438 : c status as in string status,
439 : c format as in string form. For details, see s/r openf.
440 : c
441 : c Also stores file name in list in common/cofile/, for later
442 : c access by, say, stfile.
443 : c
444 : character*(*) fn,status, form
445 : character*280 file, filess
446 : common/cofile/ nfiles, ids(99), file(99), iopen(99), filess(99)
447 : c
448 0 : nfiles=nfiles+1
449 0 : ids(nfiles)=id
450 0 : file(nfiles)=fn
451 : c
452 0 : call openf(id,status,form)
453 : c
454 0 : return
455 0 : end
456 0 : subroutine dmpfil(idsdmp)
457 : c
458 : c Output list of files, on unit idsdmp,
459 : c established by s/r ofiles in common /cofile/ and opened.
460 : c
461 : c Original version: 9/9/96
462 : c ..............................................
463 : c
464 : character*280 file, filout, filess
465 : common/cofile/ nfiles, ids(99), file(99), iopen(99), filess(99)
466 : c
467 0 : write(idsdmp,100)
468 0 : do 20 n=1,nfiles
469 0 : if(iopen(n).ne.0) then
470 0 : ll=length(file(n))
471 0 : filout=file(n)
472 0 : write(idsdmp,110) ids(n),filout(1:ll)
473 : end if
474 0 : 20 continue
475 0 : return
476 : 100 format(' Assignment of unit numbers to files:'/)
477 : 110 format(i3,':',2x,a)
478 : end
479 : block data blopen
480 : c
481 : c initialize array iopen
482 : c
483 : c New version: 7/10/97
484 : c
485 : character*280 file, filess
486 : common/cofile/ nfiles, ids(99), file(99), iopen(99), filess(99)
487 : data nfiles /0/
488 : data iopen /99*0/
489 : data filess /99*''/
490 : end
491 0 : subroutine close_file(idsst)
492 : c
493 : c closes file corresponding to unit ids and resets flag for open file
494 : c
495 : character*280 file, filein, filess
496 : common/cofile/ nfiles, ids(99), file(99), iopen(99), filess(99)
497 : c
498 : c common defining standard input and output
499 : c
500 : common/cstdio/ istdin, istdou, istdpr, istder
501 : c
502 0 : call stfile(idsst, nfs)
503 0 : iopen(nfs)=0
504 0 : close(idsst)
505 0 : return
506 : end
507 : block data blstio
508 : c
509 : c define unit numbers for standard input and output
510 : c
511 : c istdin: standard input (typically terminal)
512 : c istdou: standard output for diagnostics, etc (typically terminal)
513 : c istdpr: printed output (terminal or printer)
514 : c
515 : c For testing purposes, the initial default values are stored
516 : c separately in common/cstdio_def/
517 : c
518 : c
519 : c hp9000 version
520 : c ************
521 : c
522 : common/cstdio/ istdin, istdou, istdpr, istder
523 : common/cstdio_def/ istdin_def, istdou_def, istdpr_def, istder_def
524 : c
525 : data istdin, istdou, istdpr, istder
526 : * / 5, 6, 6, 0 /
527 : data istdin_def, istdou_def, istdpr_def, istder_def
528 : * / 5, 6, 6, 0 /
529 : end
|
