Line data Source code
1 : C-----------------------------------------------------------------------
2 : C atio.f: Input/output routines for RPFITS under linux.
3 : C-----------------------------------------------------------------------
4 : C
5 : C Notes:
6 : C 1) Cloned from the sun4sol version with tape handling stripped
7 : C out.
8 : C
9 : C $Id: atio.f,v 1.6 2007/07/16 01:11:50 cal103 Exp $
10 : C-----------------------------------------------------------------------
11 :
12 :
13 :
14 0 : integer function AT_CREATE (fname, async, initsz, lun)
15 : C-----------------------------------------------------------------------
16 : byte bufsav(2560)
17 : logical async, reread
18 : integer initsz, irec(10:99), lenrec(10:99), lun, lunsav
19 : integer istat, GETLUN
20 : character fname*(*)
21 :
22 : common /atio/ lenrec, irec, reread, lunsav, bufsav
23 : save /atio/
24 : C-----------------------------------------------------------------------
25 0 : AT_CREATE = 0
26 0 : if (fname(1:5).eq.'/dev/') then
27 0 : AT_CREATE = 1
28 :
29 : else
30 0 : istat = GETLUN(lun)
31 0 : lenrec(lun) = 2560
32 : open (lun, file=fname, status='new', access='direct',
33 0 : + form='unformatted', recl=lenrec(lun), iostat=AT_CREATE)
34 :
35 0 : irec(lun) = 1
36 : endif
37 0 : reread = .false.
38 :
39 0 : return
40 0 : end
41 :
42 :
43 :
44 0 : integer function AT_REOPEN_WRITE (fname, lun)
45 : C-----------------------------------------------------------------------
46 : C REOPEN file - on disk only.
47 : C-----------------------------------------------------------------------
48 : byte bufsav(2560)
49 : logical reread
50 : integer irec(10:99), lenrec(10:99), lun, lunsav
51 : character fname*(*)
52 :
53 : common /atio/ lenrec, irec, reread, lunsav, bufsav
54 : save /atio/
55 : C-----------------------------------------------------------------------
56 0 : AT_REOPEN_WRITE = 0
57 :
58 : open (lun, file=fname, status='old', access='direct',
59 : + form='unformatted', recl=lenrec(lun),
60 0 : + iostat=AT_REOPEN_WRITE)
61 :
62 0 : return
63 0 : end
64 :
65 :
66 :
67 0 : integer function AT_OPEN_READ (fname, async, lun)
68 : C-----------------------------------------------------------------------
69 : C "READONLY" is non-standard. Had to remove it.
70 : C-----------------------------------------------------------------------
71 : byte bufsav(2560)
72 : logical async, reread
73 : integer irec(10:99), lenrec(10:99), lun, lunsav
74 : integer istat, GETLUN
75 : character fname*(*)
76 :
77 : common /atio/ lenrec, irec, reread, lunsav, bufsav
78 : save /atio/
79 : C-----------------------------------------------------------------------
80 0 : AT_OPEN_READ = 0
81 0 : if (fname(1:5).eq.'/dev/') then
82 0 : AT_OPEN_READ = 1
83 : else
84 0 : istat = GETLUN(lun)
85 0 : lenrec(lun) = 2560
86 : open (lun, file=fname, status='old', access='direct',
87 0 : + form='unformatted', recl=lenrec(lun), iostat=AT_OPEN_READ)
88 0 : if (AT_OPEN_READ.ne.0) then
89 0 : lenrec(lun) = 512
90 : open (lun, file=fname, status='old', access='direct',
91 : + form='unformatted', recl=lenrec(lun),
92 0 : + iostat=AT_OPEN_READ)
93 : end if
94 :
95 0 : irec(lun) = 1
96 : end if
97 0 : reread = .false.
98 :
99 0 : return
100 0 : end
101 :
102 :
103 :
104 0 : integer function AT_WRITE (lun, buffer, nbytes)
105 : C-----------------------------------------------------------------------
106 : byte buffer(2560), bufsav(2560)
107 : logical reread
108 : integer irec(10:99), lenrec(10:99), lun, lunsav
109 : integer nbytes
110 :
111 : common /atio/ lenrec, irec, reread, lunsav, bufsav
112 : save /atio/
113 : C-----------------------------------------------------------------------
114 0 : AT_WRITE = 0
115 :
116 0 : write (lun, rec=irec(lun), iostat=AT_WRITE) buffer
117 0 : irec(lun) = irec(lun) + 1
118 :
119 0 : return
120 : end
121 :
122 :
123 :
124 0 : integer function AT_READ (lun, buffer)
125 : C-----------------------------------------------------------------------
126 : byte buffer(2560), bufsav(2560)
127 : logical reread
128 : integer irec(10:99), j, lenrec(10:99), lun, lunsav
129 :
130 : common /atio/ lenrec, irec, reread, lunsav, bufsav
131 : save /atio/
132 : C-----------------------------------------------------------------------
133 : C Read the next record or restore the last.
134 0 : if (reread) then
135 : C Check consistency of the input files.
136 0 : if (lun.ne.lunsav) then
137 0 : AT_READ = 999
138 0 : go to 999
139 : end if
140 :
141 : C Copy the buffer saved by AT_UNREAD to the input buffer.
142 0 : do 10 j = 1, 2560
143 0 : buffer(j) = bufsav(j)
144 0 : 10 continue
145 0 : reread = .false.
146 0 : AT_READ = 0
147 :
148 0 : else if (lenrec(lun).eq.2560) then
149 : C Get the next 2560-byte record.
150 0 : read (lun, rec=irec(lun), iostat=AT_READ) buffer
151 : C Increment record number only if read OK
152 0 : if (AT_READ.eq.0) then
153 0 : irec(lun) = irec(lun) + 1
154 : else
155 : C Not sure about this!
156 0 : AT_READ = -1
157 : end if
158 :
159 : else
160 : C Get the next five 512-byte records.
161 : read (lun, rec=irec(lun), iostat=AT_READ)
162 0 : + (buffer(j), j=1,512)
163 0 : if (AT_READ.eq.0) read (lun, rec=irec(lun)+1,
164 0 : + iostat=AT_READ) (buffer(j), j=513,1024)
165 0 : if (AT_READ.eq.0) read (lun, rec=irec(lun)+2,
166 0 : + iostat=AT_READ) (buffer(j), j=1025,1536)
167 0 : if (AT_READ.eq.0) read (lun, rec=irec(lun)+3,
168 0 : + iostat=AT_READ) (buffer(j), j=1537,2048)
169 0 : if (AT_READ.eq.0) read (lun, rec=irec(lun)+4,
170 0 : + iostat=AT_READ) (buffer(j), j=2049,2560)
171 0 : irec(lun) = irec(lun) + 5
172 : end if
173 :
174 : 999 continue
175 0 : return
176 : end
177 :
178 :
179 :
180 0 : integer function AT_SKIP_EOF (lun)
181 : C-----------------------------------------------------------------------
182 : C Returns -1 if successfully skipped to EOF, otherwise error.
183 : C-----------------------------------------------------------------------
184 : byte buffer(2560), bufsav(2560)
185 : logical reread
186 : integer irec(10:99), lenrec(10:99), lun, lunsav
187 :
188 : common /atio/ lenrec, irec, reread, lunsav, bufsav
189 : save /atio/
190 : C-----------------------------------------------------------------------
191 0 : AT_SKIP_EOF = 0
192 0 : do while (AT_SKIP_EOF.ne.-1)
193 0 : read (lun, rec=irec(lun), iostat=AT_SKIP_EOF) buffer
194 0 : irec(lun) = irec(lun) + 1
195 : end do
196 0 : reread = .false.
197 :
198 : continue
199 0 : return
200 : end
201 :
202 :
203 :
204 0 : integer function AT_UNREAD (lun, buffer)
205 : C-----------------------------------------------------------------------
206 : byte buffer(2560), bufsav(2560)
207 : logical reread
208 : integer irec(10:99), j, lenrec(10:99), lun, lunsav
209 :
210 : common /atio/ lenrec, irec, reread, lunsav, bufsav
211 : save /atio/
212 : C-----------------------------------------------------------------------
213 : C Save the buffer for "rereading".
214 0 : reread = .true.
215 0 : lunsav = lun
216 0 : do 10 j = 1, 2560
217 0 : bufsav(j) = buffer(j)
218 0 : 10 continue
219 :
220 0 : AT_UNREAD = 0
221 :
222 0 : return
223 : end
224 :
225 :
226 :
227 0 : integer function AT_CLOSE (lun)
228 : C-----------------------------------------------------------------------
229 : byte bufsav(2560)
230 : logical reread
231 : integer FREELUN, irec(10:99), istat, lenrec(10:99), lun,
232 : + lunsav
233 :
234 : common /atio/ lenrec, irec, reread, lunsav, bufsav
235 : save /atio/
236 : C-----------------------------------------------------------------------
237 0 : close (lun, iostat=AT_CLOSE)
238 0 : istat = FREELUN(lun)
239 :
240 0 : return
241 : end
242 :
243 :
244 :
245 0 : integer function GETLUN (lun)
246 : C-----------------------------------------------------------------------
247 : C Get a logical unit number.
248 : C
249 : C FORTRAN logical unit numbers are returned in the range 10 to 99.
250 : C-----------------------------------------------------------------------
251 : logical isopen
252 : integer j, fluns(10:99), lun
253 :
254 : common /lunlst/ fluns
255 : save /lunlst/
256 : C-----------------------------------------------------------------------
257 0 : GETLUN = -1
258 0 : lun = -1
259 :
260 0 : do 10 j = 99, 10, -1
261 0 : if (fluns(j).eq.0) then
262 : C Has it already been opened outside RPFITS.
263 0 : inquire (unit=j, opened=isopen)
264 0 : if (isopen) go to 10
265 :
266 0 : lun = j
267 0 : fluns(j) = -1
268 0 : GETLUN = 0
269 0 : goto 999
270 : end if
271 0 : 10 continue
272 :
273 0 : 999 return
274 : end
275 :
276 :
277 :
278 0 : integer function FREELUN (lun)
279 : C-----------------------------------------------------------------------
280 : C Free a logical unit number allocated by GETLUN.
281 : C-----------------------------------------------------------------------
282 : integer lun, fluns(10:99)
283 :
284 : common /lunlst/ fluns
285 : save /lunlst/
286 : C-----------------------------------------------------------------------
287 0 : FREELUN = 0
288 :
289 0 : if (lun.ge.10 .and. lun.le.99) then
290 0 : fluns(lun) = 0
291 : else
292 0 : FREELUN = -1
293 : end if
294 :
295 0 : return
296 : end
297 :
298 :
299 :
300 : block data
301 : C-----------------------------------------------------------------------
302 : C Initialise logical unit number lists.
303 : C-----------------------------------------------------------------------
304 : integer fluns(10:99)
305 :
306 : common /lunlst/ fluns
307 : data fluns /90*0/
308 : save /lunlst/
309 : C-----------------------------------------------------------------------
310 : end
|
