]> git.uio.no Git - u/mrichter/AliRoot.git/blame - MINICERN/packlib/zebra/rz/rzvout.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 / rzvout.F
CommitLineData
fe4da5cc 1*
2* $Id$
3*
4* $Log$
5* Revision 1.4 1997/11/24 14:47:21 jamie
6* set IOPTRR in /RZCOUT/
7*
8* Revision 1.3 1996/04/24 17:27:21 mclareni
9* Extend the include file cleanup to dzebra, rz and tq, and also add
10* dependencies in some cases.
11*
12* Revision 1.2 1996/03/08 08:08:06 jamie
13* Bug fixes for opt R handling in rz(v)out
14*
15* Revision 1.1.1.1 1996/03/06 10:47:27 mclareni
16* Zebra
17*
18*
19#include "zebra/pilot.h"
20 SUBROUTINE RZVOUT(V,N,KEYU,ICYCLE,CHOPT)
21*
22************************************************************************
23*
24* User FORTRAN array V of length N is output on a RZ file
25* Input:
26* V Fortran array of length N
27* KEYU Keyword vector of length NWKEY as specified by RZMDIR.
28* ICYCLE only used as Input parameter if 'A' option is given (see below)
29* CHOPT Character variable specifying the selected options.
30* mode
31* default
32* Array V contains only floating points
33* 'I' Array V contains integers
34* 'B' Array V contains bit-patterns
35* 'H' Array V contains Holleriths
36* 'D' Array V contains Double precision words
37* 'A' Key will not be visible by RZLDIR
38* 'R' Replace option.
39* 'S' Used for sequential operation. Application
40* guarantees that keys are unique and objects
41* are simply appended without checking all existing keys
42* Output:
43* ICYCLE Cycle number associated to the key entered
44* ICYCLE is 1 if KEY was not already present in the directory,
45* and one larger than the previous cycle associated to the key
46* otherwise.
47* ICYCLE is only Input parameter when option 'A' is given
48*
49* Called by <USER>
50*
51* Author : R.Brun DD/US/PD
52* Written : 03.04.86
53* Last mod: 25.06.93 - JDS Add IEVENT to RZWRT call (see RZWRT)
54* : 04.03.94 - S.Banerjee (Change in cycle structure)
55* : 05.09.94 - Add option S
56* : 23.03.95 J.Shiers - key # in cycles block is KEY(1)
57* : 10.04.95 J.Shiers - move IKYV lines to after definition
58* : 08.03.96 J.Shiers - use ICOLD (not 1) if opt R specified
59* : 24.11.97 M.Brun - set IOPTRR in /RZCOUT/
60*
61************************************************************************
62#include "zebra/zunit.inc"
63#include "zebra/rzcl.inc"
64#include "zebra/rzclun.inc"
65#include "zebra/rzcout.inc"
66#include "zebra/rzk.inc"
67#include "zebra/rzckey.inc"
68#include "zebra/rzcycle.inc"
69#include "zebra/mzioc.inc"
70 CHARACTER*(*) CHOPT
71 DIMENSION KEYU(*),V(*)
72 DIMENSION IOPTV(7)
73 EQUIVALENCE (IOPTA,IOPTV(1)), (IOPTD,IOPTV(2))
74 +, (IOPTI,IOPTV(3)), (IOPTB,IOPTV(4))
75 +, (IOPTH,IOPTV(5)), (IOPTR,IOPTV(6))
76 +, (IOPTS,IOPTV(7))
77*
78*-----------------------------------------------------------------------
79*
80#include "zebra/q_jbyt.inc"
81*
82 IQUEST(1)=0
83 IEVENT =0
84*
85* Loglevel
86*
87 LOGLV = JBYT(IQ(KQSP+LTOP),15,3)-3
88*
89 CALL UOPTC(CHOPT,'ADIBHRS',IOPTV)
90*
91* Set also /RZCOUT/ common variable
92*
93 IOPTRR = IOPTR
94*
95* Options R & S are incompatible
96*
97 IF(IOPTR.NE.0.AND.IOPTS.NE.0) THEN
98 IF(LOGLV.GE.3) WRITE(IQPRNT,10000)
9910000 FORMAT(' RZVOUT. ERROR - options R and S are incompatible')
100 IQUEST(1)=5
101 GOTO 999
102 ENDIF
103*
104* Check if WRITE permission on file and directory
105*
106 IF(LQRS.EQ.0)GOTO 999
107 IF(N.LE.0)THEN
108 IQUEST(1)=4
109 GOTO 999
110 ENDIF
111 IFLAG=0
112 CALL RZMODS('RZVOUT',IFLAG)
113 IF(IFLAG.NE.0)GOTO 999
114*
115* Write current buffer if not same directory
116* Get last record written in that directory
117* Create buffer bank
118*
119 LROUT = LQ(KQSP+LTOP-6)
120 IROUT = IQ(KQSP+LTOP+KIROUT)
121 IRLOUT = IQ(KQSP+LCDIR+KRLOUT)
122 IP1 = IQ(KQSP+LCDIR+KIP1)
123 IF(LROUT.EQ.0)THEN
124 CALL MZBOOK(JQPDVS,LROUT,LTOP,-6,'RZOU',0,0,LREC+1,2,-1)
125 IQ(KQSP+LROUT-5)=LUN
126 IROUT=0
127 IP1=1
128 ENDIF
129 IF(IROUT.NE.IRLOUT.AND.IRLOUT.NE.0)THEN
130 CALL RZIODO(LUN,LREC,IRLOUT,IQ(KQSP+LROUT+1),1)
131#if defined(CERNLIB_QMVAX)
132 IF(IRELAT.NE.0)UNLOCK(UNIT=LUN)
133#endif
134 IROUT=IRLOUT
135 IQ(KQSP+LTOP+KIROUT)=IROUT
136 IP1=IQ(KQSP+LCDIR+KIP1)
137 IF(IQ(KQSP+LTOP+KIRIN).EQ.IROUT)IQ(KQSP+LTOP+KIRIN) = 0
138 ENDIF
139*
140* Is directory big enough to accomodate new cycle ?
141*
142 IF(IOPTR.EQ.0) THEN
143 IF(IQ(KQSP+LCDIR+KNFREE).LT.IQ(KQSP+LCDIR+KNWKEY)+4*KLCYCL+1)
144 + THEN
145 CALL RZEXPD('RZVOUT',10*(IQ(KQSP+LCDIR+KNWKEY)+KLCYCL+1))
146 IF(IQUEST(1).NE.0)GOTO 999
147 ENDIF
148 ENDIF
149
150 LK = IQ(KQSP+LCDIR+KLK)
151 LF = IQ(KQSP+LCDIR+KLF)
152 LC = IQ(KQSP+LCDIR+KLC)
153 NWFREE=IQ(KQSP+LCDIR+KNFREE)
154
155 IF(IOPTR.EQ.0) THEN
156*
157* Compute how many records and how many words
158* are necessary to write array V.
159*
160 IR1=IRLOUT
161 IALLOC=0
162 NDATA=N
163 NLEFT=LREC-IP1+1
164 IF(NDATA.LE.NLEFT)THEN
165 NR=0
166 ELSE
167 NR=(NDATA-NLEFT-1)/LREC + 1
168 ENDIF
169 IF(IRLOUT.EQ.0)NR=NR+1
170 IF(NR.GT.0)THEN
171 CALL RZALLO('RZVOUT',NR,IALLOC)
172 IF(IALLOC.EQ.0)GOTO 999
173 ENDIF
174 IF(IRLOUT.EQ.0.OR.IP1.GT.LREC)THEN
175 IP1=1
176 NLEFT=LREC
177 IRLOUT=IALLOC
178 IR1=IALLOC
179 IR2=IALLOC+1
180 IR3=IALLOC+NR-1
181 IF(NR.EQ.1)THEN
182 IR2=0
183 IR3=0
184 ENDIF
185 ELSE
186 IR2=IALLOC
187 IR3=IALLOC+NR-1
188 ENDIF
189
190 ENDIF
191
192 NKEYS = IQ(KQSP+LCDIR+KNKEYS)
193 NWKEY = IQ(KQSP+LCDIR+KNWKEY)
194 IQUEST(7)=NKEYS
195 IQUEST(8)=NWKEY
196*
197* Convert input key vector to internal format
198*
199 DO 10 I=1,NWKEY
200 IKDES=(I-1)/10
201 IKBIT1=3*I-30*IKDES-2
202 IF(JBYT(IQ(KQSP+LCDIR+KKDES+IKDES),IKBIT1,3).LT.3)THEN
203 KEY(I)=KEYU(I)
204 ELSE
205 CALL ZHTOI(KEYU(I),KEY(I),1)
206 ENDIF
207 10 CONTINUE
208*
209* Search if KEY is already entered
210*
211 IF(IOPTS.EQ.0) THEN
212 IF(NKEYS.GT.0)THEN
213 DO 30 I=1,NKEYS
214 DO 20 K=1,NWKEY
215 LKC=LK+(NWKEY+1)*(I-1)
216 IF(IQ(KQSP+LCDIR+LKC+K).NE.KEY(K))GOTO 30
217 20 CONTINUE
218 LCOLD=IQ(KQSP+LCDIR+LKC)
219 IF (KVSCYC.NE.0) THEN
220* IF (IQ(KQSP+LCDIR+LCOLD+KKYCYC).NE.I) THEN
221 IF (IQ(KQSP+LCDIR+LCOLD+KKYCYC).NE.
222 + IQ(KQSP+LCDIR+LKC+1)) THEN
223 IQUEST(1) = 11
224 GO TO 999
225 ENDIF
226 ENDIF
227 ICOLD = JBYT(IQ(KQSP+LCDIR+LCOLD+KCNCYC),21,12)
228* IKYV = I
229 IKYV = IQ(KQSP+LCDIR+LKC+1)
230
231 IF(IOPTR.EQ.0) THEN
232 ICYCLE=ICOLD+1
233 ELSE
234* ICYCLE=1
235 ICYCLE=ICOLD
236 IF (KVSCYC.EQ.0) THEN
237 IP1 = JBYT(IQ(KQSP+LCDIR+LCOLD+KORCYC), 1,16)
238 IR1 = JBYT(IQ(KQSP+LCDIR+LCOLD+KFRCYC),17,16)
239 IR2 = JBYT(IQ(KQSP+LCDIR+LCOLD+KSRCYC),17,16)
240 NWORDS = JBYT(IQ(KQSP+LCDIR+LCOLD+KNWCYC), 1,20)
241 ELSE
242 IP1 = JBYT(IQ(KQSP+LCDIR+LCOLD+KORCYC), 1,20)
243 IR1 = IQ(KQSP+LCDIR+LCOLD+KFRCYC)
244 IR2 = IQ(KQSP+LCDIR+LCOLD+KSRCYC)
245 NWORDS = IQ(KQSP+LCDIR+LCOLD+KNWCYC)
246 ENDIF
247 NLEFT=LREC-IP1+1
248 IF(NWORDS.LE.NLEFT)THEN
249 NR=0
250 ELSE
251 NR=(NWORDS-NLEFT-1)/LREC + 1
252 ENDIF
253 IF(LOGLV.GE.3) WRITE(IQPRNT,10100) IP1,IR1,NWORDS,NR
25410100 FORMAT(' RZVOUT. object starts at word ',I6,
255 + ' in record ',I6,' nwords = ',I6,' nrecs = ',I6)
256 IF(LOGLV.GE.3.AND.IR2.NE.0) WRITE(IQPRNT,10200) IR2
25710200 FORMAT(' RZVOUT. object continues in record ',I6)
258 IRSAVE = IRLOUT
259 IF(IR1.NE.IRLOUT) THEN
260 CALL RZIODO(LUN,LREC,IR1,IQ(KQSP+LROUT+1),1)
261 IF(IQUEST(1).NE.0)GOTO 999
262 IROUT = IR1
263 IRLOUT = IR1
264 ENDIF
265 ENDIF
266
267 IQUEST(20)=I
268 GOTO 50
269 30 CONTINUE
270 ENDIF
271*
272* Object must already exist if R option is given
273*
274 IF(IOPTR.NE.0) THEN
275 IQUEST(1) = 6
276 IF(LOGLV.GE.-2) WRITE(IQLOG,10300)
27710300 FORMAT(' RZVOUT. Error - object does not exist')
278 GOTO 999
279 ENDIF
280
281 ENDIF
282*
283* New KEY, append to the list
284*
285 IQUEST(20)=NWKEY+1
286 NWFREE=NWFREE-NWKEY-1
287 IQ(KQSP+LCDIR+KNKEYS)=IQ(KQSP+LCDIR+KNKEYS)+1
288 LCOLD = 0
289 LKC = LF
290 LF = LF+NWKEY+1
291 ICYCLE= 1
292 DO 40 I=1,NWKEY
293 IQ(KQSP+LCDIR+LKC+I)=KEY(I)
294 40 CONTINUE
295* IKYV = IQ(KQSP+LCDIR+KNKEYS)
296 IKYV = IQ(KQSP+LCDIR+LKC+1)
297*
298* Write user array
299*
300 50 IQ3=IRLOUT
301 IQ4=IP1
302
303#if !defined(CERNLIB_FQXISN)
304 IF(IMODEX.GT.0)THEN
305 MFO(1)= 3
306 IF(IOPTI.NE.0)MFO(1)=2
307 IF(IOPTB.NE.0)MFO(1)=1
308 IF(IOPTH.NE.0)MFO(1)=5
309 MFO(2)=-1
310 JFOEND= 2
311 ENDIF
312#endif
313 CALL RZWRT(V,NDATA,IOPTB,IEVENT)
314 IF(IQUEST(1).NE.0)THEN
315 IF(ICYCLE.EQ.1.AND.IOPTR.EQ.0)THEN
316 IQ(KQSP+LCDIR+KNKEYS)=IQ(KQSP+LCDIR+KNKEYS)-1
317 ENDIF
318 IROUT=IQ(KQSP+LTOP+KIROUT)
319 IF(IROUT.GT.0)THEN
320 IQ1=IQUEST(1)
321 CALL RZIODO(LUN,LREC,IROUT,IQ(KQSP+LROUT+1),1)
322#if defined(CERNLIB_QMVAX)
323 IF(IRELAT.NE.0)UNLOCK(UNIT=LUN)
324#endif
325 IQUEST(1)=IQ1
326 ENDIF
327 GOTO 999
328 ENDIF
329
330 IF(IOPTR.EQ.0) THEN
331 IF(IRLOUT.EQ.IR1) GOTO 60
332 IF(IRLOUT.GE.IR2.AND.IRLOUT.LE.IR3) GOTO 60
333 IF(IROUT.EQ.IRLOUT)IROUT=0
334 IRLOUT = 0
335 IP1 = 1
336 60 CONTINUE
337*
338* Create a new cycle
339*
340 LC = LC-KLCYCL
341 NWFREE= NWFREE-KLCYCL
342 IFORM = 3
343 IF(IOPTI.NE.0) IFORM = 2
344 IF(IOPTB.NE.0) IFORM = 1
345 IF(IOPTH.NE.0) IFORM = 5
346 IQ(KQSP+LCDIR+LKC) = LC
347 IQ(KQSP+LCDIR+LC+KPPCYC) = LCOLD
348 IQ(KQSP+LCDIR+LC+KFLCYC) = IFORM
349 CALL RZDATE(IQ(KQSP+LCDIR+LC+KFLCYC),IDATE,ITIME,2)
350 IF(IOPTA.NE.0) CALL SBIT1(IQ(KQSP+LCDIR+LC+KFLCYC),4)
351 IQ(KQSP+LCDIR+LC+KORCYC) = IQ4
352 IQ(KQSP+LCDIR+LC+KNWCYC) = NDATA
353 CALL SBYT(ICYCLE,IQ(KQSP+LCDIR+LC+KCNCYC),21,12)
354 IF (KVSCYC.EQ.0) THEN
355 IF (NLEFT.LT.NDATA)
356 + CALL SBYT(IR2,IQ(KQSP+LCDIR+LC+KSRCYC),17,16)
357 CALL SBYT(IR1,IQ(KQSP+LCDIR+LC+KFRCYC),17,16)
358 ELSE
359 IF (NLEFT.LT.NDATA) THEN
360 IQ(KQSP+LCDIR+LC+KSRCYC) = IR2
361 ELSE
362 IQ(KQSP+LCDIR+LC+KSRCYC) = 0
363 ENDIF
364 IQ(KQSP+LCDIR+LC+KFRCYC) = IR1
365 IQ(KQSP+LCDIR+LC+KKYCYC) = IKYV
366 ENDIF
367 ENDIF
368*
369* Update internal pointers in the directory
370*
371 IQUEST(3)=IQ3
372 IQUEST(4)=IQ4
373 IQUEST(5)=0
374 IQUEST(6)=ICYCLE
375 IQUEST(11)=NDATA
376
377 IF(IOPTR.EQ.0) THEN
378
379 IQ(KQSP+LTOP+KIROUT)=IROUT
380 IQ(KQSP+LCDIR+KRUSED)=IQ(KQSP+LCDIR+KRUSED)+NR
381 NWUSED=IQ(KQSP+LCDIR+KWUSED)+NDATA
382 IF(NWUSED.GT.1000000)THEN
383 IQ(KQSP+LCDIR+KMEGA)=IQ(KQSP+LCDIR+KMEGA)+1
384 IQ(KQSP+LCDIR+KWUSED)=NWUSED-1000000
385 ELSE
386 IQ(KQSP+LCDIR+KWUSED)=NWUSED
387 ENDIF
388 IQ(KQSP+LCDIR+KRLOUT)=IRLOUT
389 IQ(KQSP+LCDIR+KIP1)=IP1
390 IQ(KQSP+LCDIR+KNFREE)=NWFREE
391 IQ(KQSP+LCDIR+KLF)=LF
392 IQ(KQSP+LCDIR+KLC)=LC
393
394 ENDIF
395
396 IQUEST(9)=IQ(KQSP+LCDIR+KQUOTA)-IQ(KQSP+LCDIR+KRUSED)
397*
398* Mark used records
399*
400 IF(IOPTR.EQ.0.AND.NR.GT.0)THEN
401 CALL RZUSED(NR,IALLOC)
402 ENDIF
403*
404* Restore last record written if required
405*
406 IF(IOPTR.NE.0.AND.IRSAVE.NE.IRLOUT) THEN
407 CALL RZIODO(LUN,LREC,IRLOUT,IQ(KQSP+LROUT+1),2)
408 IF(IQUEST(1).NE.0)GOTO 999
409 IROUT = IRSAVE
410 IRLOUT = IRSAVE
411 CALL RZIODO(LUN,LREC,IRLOUT,IQ(KQSP+LROUT+1),1)
412 IF(IQUEST(1).NE.0)GOTO 999
413 ENDIF
414*
415 999 END