]>
Commit | Line | Data |
---|---|---|
fe4da5cc | 1 | * |
2 | * $Id$ | |
3 | * | |
4 | * $Log$ | |
5 | * Revision 1.3 1996/04/24 17:27:03 mclareni | |
6 | * Extend the include file cleanup to dzebra, rz and tq, and also add | |
7 | * dependencies in some cases. | |
8 | * | |
9 | * Revision 1.2 1996/03/08 08:08:04 jamie | |
10 | * Bug fixes for opt R handling in rz(v)out | |
11 | * | |
12 | * Revision 1.1.1.1 1996/03/06 10:47:26 mclareni | |
13 | * Zebra | |
14 | * | |
15 | * | |
16 | #include "zebra/pilot.h" | |
17 | SUBROUTINE RZOUT(IXDIV,LSUP,KEYU,ICYCLE,CHOPT) | |
18 | * | |
19 | ************************************************************************ | |
20 | * | |
21 | * To write data structure pointed by LSUP | |
22 | * Input: | |
23 | * IXDIV Index of the division(s) | |
24 | * May be zero if the 'D' option is not selected | |
25 | * May be a compound index (see MZIXCO on page 24) if the 'D' | |
26 | * option is selected | |
27 | * LSUP Supporting address of the data structure (may be zero if the | |
28 | * 'D' option is selected) | |
29 | * KEYU Keyword vector of length NWKEY as specified by RZMDIR. | |
30 | * ICYCLE only used as Input parameter if 'A' option is given (see below) | |
31 | * CHOPT Character variable specifying the selected options. | |
32 | * data structure | |
33 | * default | |
34 | * The data structure supported by the bank at LSUP is | |
35 | * written out (link 0 is not followed) | |
36 | * 'D' Complete division(s) | |
37 | * default: Dropped banks are squeezed out | |
38 | * (slower but maybe more economic than 'DI') | |
39 | * 'DI' Immediate dump of divisions with dropped banks | |
40 | * included | |
41 | * 'L' Write the data structure supported by the linear | |
42 | * structure at LSUP (link 0 is followed) | |
43 | * 'S' Single bank at LSUP | |
44 | * 'R' Replace option. | |
45 | * 'Q' seQuential mode - no check made to see if key already | |
46 | * exists (option S in RZVOUT etc.) | |
47 | * mode | |
48 | * default | |
49 | * Keep banks available after output | |
50 | * 'N' No links, i.e. linkless handling | |
51 | * 'W' Drop data structure or wipe division(s) after output | |
52 | * 'A' Key will not be visible by RZLDIR | |
53 | * Output: | |
54 | * ICYCLE Cycle number associated to the key entered | |
55 | * ICYCLE is 1 if KEY was not already present in the directory, | |
56 | * and one larger than the previous cycle associated to the key | |
57 | * otherwise. | |
58 | * ICYCLE is only Input parameter when option 'A' is given | |
59 | * | |
60 | * Called by <USER> | |
61 | * | |
62 | * Author : R.Brun DD/US/PD | |
63 | * Written : 04.04.86 | |
64 | * Last mod: 14.09.93 - RB. Protect against directories > 64K | |
65 | * : 04.03.94 S.Banerjee (Change in cycle structure) | |
66 | * : 27.09.94 J.Shiers - add option Q (cf S in RZVOUT) | |
67 | * : 17.02.95 J.Shiers - move definition of logl | |
68 | * : 21.02.95 J.Shiers - improve warning message for | |
69 | * big directories (objects auto-deleted) | |
70 | * : 23.03.95 J.Shiers - key # in cycles block is KEY(1) | |
71 | * : 10.04.95 J.Shiers - move IKYV lines to after definition | |
72 | * : 08.03.96 J.Shiers - only delete previous cycle if opt R | |
73 | * not specified. If opt R is specified, | |
74 | * use previous cycle number (and not 1) | |
75 | * | |
76 | * In RZ file format version 0, RZ pointers are stored in 16 bits. | |
77 | * Thus, pointers to previous cycle etc. must not exceed 65536. | |
78 | * An attempt to save a new cycle under such conditions will result | |
79 | * in the previous cycle being deleted with a warning message. | |
80 | * | |
81 | * For files created with RZ version 1, this is not necessary as | |
82 | * pointers are 32 bit. | |
83 | * | |
84 | ************************************************************************ | |
85 | #include "zebra/zunit.inc" | |
86 | #include "zebra/rzcl.inc" | |
87 | #include "zebra/rzclun.inc" | |
88 | #include "zebra/eqlqrrf.inc" | |
89 | #include "zebra/rzcout.inc" | |
90 | #include "zebra/rzk.inc" | |
91 | #include "zebra/rzckey.inc" | |
92 | #include "zebra/rzcycle.inc" | |
93 | #include "zebra/mzct.inc" | |
94 | #include "zebra/fzcx.inc" | |
95 | CHARACTER*(*) CHOPT | |
96 | DIMENSION KEYU(*) | |
97 | DIMENSION LSUP(1) | |
98 | DIMENSION IOPTV(9) | |
99 | * | |
100 | *----------------------------------------------------------------------- | |
101 | * | |
102 | #include "zebra/q_jbyt.inc" | |
103 | * | |
104 | IQUEST(1)=0 | |
105 | CALL MZSDIV(IXDIV,1) | |
106 | IXDIVX=IXDIV | |
107 | LQRRF(KQT+1)=LSUP(1) | |
108 | IEVFLX=1 | |
109 | NWTXX =0 | |
110 | NWSEGX=0 | |
111 | NWTABX=0 | |
112 | NWBKX =0 | |
113 | NWUHCX=0 | |
114 | CALL UOPTC(CHOPT,'ADILSNWRQ',IOPTV) | |
115 | IOPTXA=IOPTV(1) | |
116 | IOPTXD=IOPTV(2) | |
117 | IOPTXI=IOPTV(3) | |
118 | IOPTXL=IOPTV(4) | |
119 | IOPTXS=IOPTV(5) | |
120 | IOPTXN=IOPTV(6) | |
121 | IOPTXW=IOPTV(7) | |
122 | IOPTXR=IOPTV(8) | |
123 | IOPTRR=IOPTV(8) | |
124 | IOPTXQ=IOPTV(9) | |
125 | IOPTXN=IOPTXN+IOPTXS | |
126 | IOPTXM=0 | |
127 | * | |
128 | * Loglevel | |
129 | * | |
130 | LOGLV = JBYT(IQ(KQSP+LTOP),15,3)-3 | |
131 | * | |
132 | * Options R & Q are incompatible | |
133 | * | |
134 | IF(IOPTXR.NE.0.AND.IOPTXQ.NE.0) THEN | |
135 | IF(LOGLV.GE.3) WRITE(IQPRNT,10000) | |
136 | 10000 FORMAT(' RZOUT. ERROR - options R and Q are incompatible') | |
137 | IQUEST(1)=5 | |
138 | GOTO 999 | |
139 | ENDIF | |
140 | * | |
141 | * Check if WRITE permission on file and directory | |
142 | * | |
143 | IF(LQRS.EQ.0)GOTO 999 | |
144 | IFLAG=0 | |
145 | CALL RZMODS('RZOUT ',IFLAG) | |
146 | IF(IFLAG.NE.0) GOTO 999 | |
147 | * | |
148 | * Write current buffer if not same directory | |
149 | * Get last record written in that directory | |
150 | * Create buffer bank | |
151 | * | |
152 | 10 LROUT = LQ(KQSP+LTOP-6) | |
153 | IROUT = IQ(KQSP+LTOP+KIROUT) | |
154 | IRLOUT = IQ(KQSP+LCDIR+KRLOUT) | |
155 | IP1 = IQ(KQSP+LCDIR+KIP1) | |
156 | IF(LROUT.EQ.0)THEN | |
157 | CALL MZBOOK(JQPDVS,LROUT,LTOP,-6,'RZOU',0,0,LREC+1,2,-1) | |
158 | IQ(KQSP+LROUT-5)=LUN | |
159 | IROUT=0 | |
160 | IP1=1 | |
161 | ENDIF | |
162 | IF(IROUT.NE.IRLOUT.AND.IRLOUT.NE.0)THEN | |
163 | CALL RZIODO(LUN,LREC,IRLOUT,IQ(KQSP+LROUT+1),1) | |
164 | IF(IQUEST(1).NE.0)GOTO 999 | |
165 | #if defined(CERNLIB_QMVAX) | |
166 | IF(IRELAT.NE.0)UNLOCK(UNIT=LUN) | |
167 | #endif | |
168 | IROUT=IRLOUT | |
169 | IQ(KQSP+LTOP+KIROUT)=IROUT | |
170 | IP1=IQ(KQSP+LCDIR+KIP1) | |
171 | IF(IQ(KQSP+LTOP+KIRIN).EQ.IROUT)IQ(KQSP+LTOP+KIRIN) = 0 | |
172 | ENDIF | |
173 | * | |
174 | * Is directory big enough to accomodate new cycle ? | |
175 | * | |
176 | NKEYS = IQ(KQSP+LCDIR+KNKEYS) | |
177 | NWKEY = IQ(KQSP+LCDIR+KNWKEY) | |
178 | ||
179 | IF(IOPTXR.EQ.0) THEN | |
180 | IF(IQ(KQSP+LCDIR+KNFREE).LT.NWKEY+4*KLCYCL+1)THEN | |
181 | CALL RZEXPD('RZOUT ',10*(NWKEY+KLCYCL+1)) | |
182 | IF(IQUEST(1).NE.0)GOTO 999 | |
183 | ENDIF | |
184 | ENDIF | |
185 | ||
186 | LK = IQ(KQSP+LCDIR+KLK) | |
187 | LF = IQ(KQSP+LCDIR+KLF) | |
188 | LC = IQ(KQSP+LCDIR+KLC) | |
189 | LE = IQ(KQSP+LCDIR+KLE) | |
190 | NWFREE=IQ(KQSP+LCDIR+KNFREE) | |
191 | * | |
192 | * Convert input key vector to internal format | |
193 | * | |
194 | IQUEST(7)=NKEYS | |
195 | IQUEST(8)=NWKEY | |
196 | * | |
197 | DO 20 I=1,NWKEY | |
198 | IKDES=(I-1)/10 | |
199 | IKBIT1=3*I-30*IKDES-2 | |
200 | IF(JBYT(IQ(KQSP+LCDIR+KKDES+IKDES),IKBIT1,3).LT.3)THEN | |
201 | KEY(I)=KEYU(I) | |
202 | ELSE | |
203 | CALL ZHTOI(KEYU(I),KEY(I),1) | |
204 | ENDIF | |
205 | 20 CONTINUE | |
206 | * | |
207 | * Search if KEY is already entered | |
208 | * | |
209 | IF(IOPTXQ.EQ.0) THEN | |
210 | IF(NKEYS.GT.0)THEN | |
211 | DO 40 I=1,NKEYS | |
212 | DO 30 K=1,NWKEY | |
213 | LKC=LK+(NWKEY+1)*(I-1) | |
214 | IF(IQ(KQSP+LCDIR+LKC+K).NE.KEY(K))GOTO 40 | |
215 | 30 CONTINUE | |
216 | * | |
217 | * Protect against directories > 65536 | |
218 | * | |
219 | IF(IOPTXR.EQ.0.AND.KVSCYC.EQ.0.AND.LE.GT.65536)THEN | |
220 | CALL RZDELK(KEYU,0,'C') | |
221 | IF(LOGLV.GE.-2) THEN | |
222 | WRITE(IQPRNT,10100) | |
223 | 10100 FORMAT(' RZOUT: current RZ file cannot support > 64K records ',/, | |
224 | + ' or individual directories > 64K') | |
225 | WRITE(IQPRNT,10200)KEY(1) | |
226 | 10200 FORMAT(' RZOUT: previous cycle(s) for this key (',I8,')', | |
227 | + ' deleted') | |
228 | WRITE(IQPRNT,10300) | |
229 | 10300 FORMAT(' RZOUT: please consult ZEBRA manual for further details') | |
230 | ENDIF | |
231 | GOTO 10 | |
232 | ENDIF | |
233 | ||
234 | LCOLD=IQ(KQSP+LCDIR+LKC) | |
235 | IF (KVSCYC.NE.0) THEN | |
236 | * IF (IQ(KQSP+LCDIR+LCOLD+KKYCYC).NE.I) THEN | |
237 | LKC=LK+(NWKEY+1)*(I-1) | |
238 | IF (IQ(KQSP+LCDIR+LCOLD+KKYCYC).NE. | |
239 | + IQ(KQSP+LCDIR+LKC+1)) THEN | |
240 | IQUEST(1) = 11 | |
241 | GO TO 999 | |
242 | ENDIF | |
243 | ENDIF | |
244 | ICOLD = JBYT(IQ(KQSP+LCDIR+LCOLD+KCNCYC),21,12) | |
245 | * IKYV = I | |
246 | IKYV = IQ(KQSP+LCDIR+LKC+1) | |
247 | IF(IOPTXR.EQ.0) THEN | |
248 | ICYCLE=ICOLD+1 | |
249 | ELSE | |
250 | * ICYCLE=1 | |
251 | ICYCLE=ICOLD | |
252 | IF (KVSCYC.EQ.0) THEN | |
253 | IP1 = JBYT(IQ(KQSP+LCDIR+LCOLD+KORCYC), 1,16) | |
254 | IR1 = JBYT(IQ(KQSP+LCDIR+LCOLD+KFRCYC),17,16) | |
255 | IR2 = JBYT(IQ(KQSP+LCDIR+LCOLD+KSRCYC),17,16) | |
256 | NWORDS = JBYT(IQ(KQSP+LCDIR+LCOLD+KNWCYC), 1,20) | |
257 | ELSE | |
258 | IP1 = JBYT(IQ(KQSP+LCDIR+LCOLD+KORCYC), 1,20) | |
259 | IR1 = IQ(KQSP+LCDIR+LCOLD+KFRCYC) | |
260 | IR2 = IQ(KQSP+LCDIR+LCOLD+KSRCYC) | |
261 | NWORDS = IQ(KQSP+LCDIR+LCOLD+KNWCYC) | |
262 | ENDIF | |
263 | NLEFT=LREC-IP1+1 | |
264 | IF(NWORDS.LE.NLEFT)THEN | |
265 | NR=0 | |
266 | ELSE | |
267 | NR=(NWORDS-NLEFT-1)/LREC + 1 | |
268 | ENDIF | |
269 | IF(LOGLV.GE.3) WRITE(IQPRNT,10400) IP1,IR1,NWORDS,NR | |
270 | 10400 FORMAT(' RZOUT. object starts at word ',I6, | |
271 | + ' in record ',I6,' nwords = ',I6,' nrecs = ',I6) | |
272 | IF(LOGLV.GE.3.AND.IR2.NE.0) WRITE(IQPRNT,10500) IR2 | |
273 | 10500 FORMAT(' RZOUT. object continues in record ',I6) | |
274 | IRSAVE = IRLOUT | |
275 | IF(IR1.NE.IRLOUT) THEN | |
276 | CALL RZIODO(LUN,LREC,IR1,IQ(KQSP+LROUT+1),1) | |
277 | IF(IQUEST(1).NE.0)GOTO 999 | |
278 | IROUT = IR1 | |
279 | IRLOUT = IR1 | |
280 | ENDIF | |
281 | ENDIF | |
282 | IQUEST(20)=I | |
283 | GOTO 60 | |
284 | 40 CONTINUE | |
285 | ENDIF | |
286 | * | |
287 | * Object must already exist if R option is given | |
288 | * | |
289 | IF(IOPTXR.NE.0) THEN | |
290 | IQUEST(1) = 6 | |
291 | IF(LOGLV.GE.-2) WRITE(IQLOG,10600) | |
292 | 10600 FORMAT(' RZOUT. Error - object does not exist') | |
293 | GOTO 999 | |
294 | ENDIF | |
295 | ENDIF | |
296 | * | |
297 | * New KEY, append to the list | |
298 | * | |
299 | IQUEST(20)=NWKEY+1 | |
300 | NWFREE=NWFREE-NWKEY-1 | |
301 | IQ(KQSP+LCDIR+KNKEYS)=IQ(KQSP+LCDIR+KNKEYS)+1 | |
302 | LCOLD = 0 | |
303 | LKC = LF | |
304 | LF = LF+NWKEY+1 | |
305 | ICYCLE= 1 | |
306 | DO 50 I=1,NWKEY | |
307 | IQ(KQSP+LCDIR+LKC+I)=KEY(I) | |
308 | 50 CONTINUE | |
309 | * IKYV = IQ(KQSP+LCDIR+KNKEYS) | |
310 | IKYV = IQ(KQSP+LCDIR+LKC+1) | |
311 | * | |
312 | * Construct table of material to be written | |
313 | * | |
314 | 60 CALL MZSDIV(IXDIVX,0) | |
315 | LENTRX = LQRRF(KQT+1) | |
316 | JQSTMV = -1 | |
317 | MODTBX = 0 | |
318 | JFLGAX = 0 | |
319 | CALL FZOTAB | |
320 | IF(IQUEST(1).NE.0)THEN | |
321 | IF(LOGLV.GE.-2) WRITE(IQLOG,10700) | |
322 | 10700 FORMAT(' RZOUT. Unable to construct table') | |
323 | GOTO 80 | |
324 | ENDIF | |
325 | IF(IOPTXN.NE.0)NWTABX=0 | |
326 | NDATA=NWTABX+NWBKX+3 | |
327 | * | |
328 | * Replace option - record allocation not required | |
329 | * | |
330 | IF(IOPTXR.NE.0) THEN | |
331 | * | |
332 | * Check if exactly the same number of words are required | |
333 | * | |
334 | IF(NDATA.NE.NWORDS) THEN | |
335 | IQUEST(1) = 1 | |
336 | IF(LOGLV.GE.-2) WRITE(IQLOG,10800) NWORDS,NDATA | |
337 | 10800 FORMAT(' RZOUT. Error - existing object required ',I10, | |
338 | + ' words. New object requires ',I10) | |
339 | GOTO 90 | |
340 | ENDIF | |
341 | ||
342 | ELSE | |
343 | * | |
344 | * Compute how many records and how many words | |
345 | * are necessary to write data structure. | |
346 | * | |
347 | IR1=IRLOUT | |
348 | IALLOC=0 | |
349 | NLEFT=LREC-IP1+1 | |
350 | IF(NDATA.LE.NLEFT)THEN | |
351 | NR=0 | |
352 | ELSE | |
353 | NR=(NDATA-NLEFT-1)/LREC + 1 | |
354 | ENDIF | |
355 | IF(IRLOUT.EQ.0)NR=NR+1 | |
356 | IF(NR.GT.0)THEN | |
357 | CALL RZALLO('RZOUT ',NR,IALLOC) | |
358 | IF(IALLOC.EQ.0)GOTO 80 | |
359 | ENDIF | |
360 | IF(IRLOUT.EQ.0.OR.IP1.GT.LREC)THEN | |
361 | IP1=1 | |
362 | NLEFT=LREC | |
363 | IRLOUT=IALLOC | |
364 | IR1=IALLOC | |
365 | IR2=IALLOC+1 | |
366 | IR3=IALLOC+NR-1 | |
367 | IF(NR.EQ.1)THEN | |
368 | IR2=0 | |
369 | IR3=0 | |
370 | ENDIF | |
371 | ELSE | |
372 | IR2=IALLOC | |
373 | IR3=IALLOC+NR-1 | |
374 | ENDIF | |
375 | ENDIF | |
376 | IQ3 =IRLOUT | |
377 | IQ4 =IP1 | |
378 | * | |
379 | * Write data structure at LSUP according to table | |
380 | * | |
381 | CALL RZOBKN | |
382 | IF(IQUEST(1).NE.0)THEN | |
383 | IROUT=IQ(KQSP+LTOP+KIROUT) | |
384 | IF(IROUT.GT.0)THEN | |
385 | IQ1=IQUEST(1) | |
386 | CALL RZIODO(LUN,LREC,IROUT,IQ(KQSP+LROUT+1),1) | |
387 | #if defined(CERNLIB_QMVAX) | |
388 | IF(IRELAT.NE.0)UNLOCK(UNIT=LUN) | |
389 | #endif | |
390 | IQUEST(1)=IQ1 | |
391 | ENDIF | |
392 | GOTO 80 | |
393 | ENDIF | |
394 | ||
395 | IF(IOPTXR.EQ.0) THEN | |
396 | ||
397 | IF(IRLOUT.EQ.IR1) GOTO 70 | |
398 | IF(IRLOUT.GE.IR2.AND.IRLOUT.LE.IR3) GOTO 70 | |
399 | IF(IROUT.EQ.IRLOUT)IROUT=0 | |
400 | IRLOUT = 0 | |
401 | IP1 = 1 | |
402 | 70 CONTINUE | |
403 | * | |
404 | * Create a new cycle | |
405 | * | |
406 | LC = LC-KLCYCL | |
407 | NWFREE = NWFREE-KLCYCL | |
408 | IQ(KQSP+LCDIR+LKC) = LC | |
409 | IQ(KQSP+LCDIR+LC+KPPCYC) = LCOLD | |
410 | IQ(KQSP+LCDIR+LC+KFLCYC) = 0 | |
411 | CALL RZDATE (IQ(KQSP+LCDIR+LC+KFLCYC),IDATE,ITIME,2) | |
412 | IF(IOPTXA.NE.0)CALL SBIT1(IQ(KQSP+LCDIR+LC+KFLCYC),4) | |
413 | IQ(KQSP+LCDIR+LC+KORCYC) = IQ4 | |
414 | IQ(KQSP+LCDIR+LC+KNWCYC) = NDATA | |
415 | CALL SBYT(ICYCLE,IQ(KQSP+LCDIR+LC+KCNCYC),21,12) | |
416 | IF (KVSCYC.EQ.0) THEN | |
417 | IF (NLEFT.LT.NDATA) | |
418 | + CALL SBYT(IR2,IQ(KQSP+LCDIR+LC+KSRCYC),17,16) | |
419 | CALL SBYT(IR1,IQ(KQSP+LCDIR+LC+KFRCYC),17,16) | |
420 | ELSE | |
421 | IF (NLEFT.LT.NDATA) THEN | |
422 | IQ(KQSP+LCDIR+LC+KSRCYC) = IR2 | |
423 | ELSE | |
424 | IQ(KQSP+LCDIR+LC+KSRCYC) = 0 | |
425 | ENDIF | |
426 | IQ(KQSP+LCDIR+LC+KFRCYC) = IR1 | |
427 | IQ(KQSP+LCDIR+LC+KKYCYC) = IKYV | |
428 | ENDIF | |
429 | ENDIF | |
430 | * | |
431 | * Update internal pointers in the directory | |
432 | * | |
433 | IQUEST(3)=IQ3 | |
434 | IQUEST(4)=IQ4 | |
435 | IQUEST(5)=0 | |
436 | IQUEST(6)=ICYCLE | |
437 | IQUEST(11)=NDATA | |
438 | ||
439 | IF(IOPTXR.EQ.0) THEN | |
440 | ||
441 | IQ(KQSP+LTOP+KIROUT)=IROUT | |
442 | IQ(KQSP+LCDIR+KRUSED)=IQ(KQSP+LCDIR+KRUSED)+NR | |
443 | NWUSED=IQ(KQSP+LCDIR+KWUSED)+NDATA | |
444 | IF(NWUSED.GT.1000000)THEN | |
445 | IQ(KQSP+LCDIR+KMEGA)=IQ(KQSP+LCDIR+KMEGA)+1 | |
446 | IQ(KQSP+LCDIR+KWUSED)=NWUSED-1000000 | |
447 | ELSE | |
448 | IQ(KQSP+LCDIR+KWUSED)=NWUSED | |
449 | ENDIF | |
450 | IQ(KQSP+LCDIR+KRLOUT)=IRLOUT | |
451 | IQ(KQSP+LCDIR+KIP1)=IP1 | |
452 | IQ(KQSP+LCDIR+KNFREE)=NWFREE | |
453 | IQ(KQSP+LCDIR+KLF)=LF | |
454 | IQ(KQSP+LCDIR+KLC)=LC | |
455 | ||
456 | ENDIF | |
457 | ||
458 | IQUEST(9)=IQ(KQSP+LCDIR+KQUOTA)-IQ(KQSP+LCDIR+KRUSED) | |
459 | * | |
460 | * Drop data structure or wipe division (option W) | |
461 | * | |
462 | IF (IOPTXW.NE.0) THEN | |
463 | LSUP(1) = LQRRF(KQT+1) | |
464 | IF (LSUP(1).NE.0) THEN | |
465 | CALL MZDROP(IXDIV,LSUP,' ') | |
466 | LSUP(1)=0 | |
467 | ENDIF | |
468 | ENDIF | |
469 | * | |
470 | * Mark used records | |
471 | * | |
472 | IF(IOPTXR.EQ.0.AND.NR.GT.0)THEN | |
473 | CALL RZUSED(NR,IALLOC) | |
474 | ENDIF | |
475 | GOTO 90 | |
476 | 80 IF(ICYCLE.EQ.1.AND.IOPTXR.EQ.0)THEN | |
477 | IQ(KQSP+LCDIR+KNKEYS)=IQ(KQSP+LCDIR+KNKEYS)-1 | |
478 | ENDIF | |
479 | ||
480 | 90 CONTINUE | |
481 | * | |
482 | * Restore last record written if required | |
483 | * | |
484 | IF(IOPTXR.NE.0.AND.IRSAVE.NE.IRLOUT) THEN | |
485 | CALL RZIODO(LUN,LREC,IRLOUT,IQ(KQSP+LROUT+1),2) | |
486 | IF(IQUEST(1).NE.0)GOTO 999 | |
487 | IROUT = IRSAVE | |
488 | IRLOUT = IRSAVE | |
489 | CALL RZIODO(LUN,LREC,IRLOUT,IQ(KQSP+LROUT+1),1) | |
490 | IF(IQUEST(1).NE.0)GOTO 999 | |
491 | ENDIF | |
492 | * | |
493 | 999 END |