]> git.uio.no Git - u/mrichter/AliRoot.git/blame - MINICERN/packlib/zebra/rz/rzout.F
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Bugfix in AliPoints2Memory
[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / rz / rzout.F
CommitLineData
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)
13610000 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)
22310100 FORMAT(' RZOUT: current RZ file cannot support > 64K records ',/,
224 + ' or individual directories > 64K')
225 WRITE(IQPRNT,10200)KEY(1)
22610200 FORMAT(' RZOUT: previous cycle(s) for this key (',I8,')',
227 + ' deleted')
228 WRITE(IQPRNT,10300)
22910300 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
27010400 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
27310500 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)
29210600 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)
32210700 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
33710800 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