5 * Revision 1.4 1997/11/24 14:47:21 jamie
6 * set IOPTRR in /RZCOUT/
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.
12 * Revision 1.2 1996/03/08 08:08:06 jamie
13 * Bug fixes for opt R handling in rz(v)out
15 * Revision 1.1.1.1 1996/03/06 10:47:27 mclareni
19 #include "zebra/pilot.h"
20 SUBROUTINE RZVOUT(V,N,KEYU,ICYCLE,CHOPT)
22 ************************************************************************
24 * User FORTRAN array V of length N is output on a RZ file
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.
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
39 * 'S' Used for sequential operation. Application
40 * guarantees that keys are unique and objects
41 * are simply appended without checking all existing keys
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
47 * ICYCLE is only Input parameter when option 'A' is given
51 * Author : R.Brun DD/US/PD
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/
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"
71 DIMENSION KEYU(*),V(*)
73 EQUIVALENCE (IOPTA,IOPTV(1)), (IOPTD,IOPTV(2))
74 +, (IOPTI,IOPTV(3)), (IOPTB,IOPTV(4))
75 +, (IOPTH,IOPTV(5)), (IOPTR,IOPTV(6))
78 *-----------------------------------------------------------------------
80 #include "zebra/q_jbyt.inc"
87 LOGLV = JBYT(IQ(KQSP+LTOP),15,3)-3
89 CALL UOPTC(CHOPT,'ADIBHRS',IOPTV)
91 * Set also /RZCOUT/ common variable
95 * Options R & S are incompatible
97 IF(IOPTR.NE.0.AND.IOPTS.NE.0) THEN
98 IF(LOGLV.GE.3) WRITE(IQPRNT,10000)
99 10000 FORMAT(' RZVOUT. ERROR - options R and S are incompatible')
104 * Check if WRITE permission on file and directory
106 IF(LQRS.EQ.0)GOTO 999
112 CALL RZMODS('RZVOUT',IFLAG)
113 IF(IFLAG.NE.0)GOTO 999
115 * Write current buffer if not same directory
116 * Get last record written in that directory
119 LROUT = LQ(KQSP+LTOP-6)
120 IROUT = IQ(KQSP+LTOP+KIROUT)
121 IRLOUT = IQ(KQSP+LCDIR+KRLOUT)
122 IP1 = IQ(KQSP+LCDIR+KIP1)
124 CALL MZBOOK(JQPDVS,LROUT,LTOP,-6,'RZOU',0,0,LREC+1,2,-1)
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)
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
140 * Is directory big enough to accomodate new cycle ?
143 IF(IQ(KQSP+LCDIR+KNFREE).LT.IQ(KQSP+LCDIR+KNWKEY)+4*KLCYCL+1)
145 CALL RZEXPD('RZVOUT',10*(IQ(KQSP+LCDIR+KNWKEY)+KLCYCL+1))
146 IF(IQUEST(1).NE.0)GOTO 999
150 LK = IQ(KQSP+LCDIR+KLK)
151 LF = IQ(KQSP+LCDIR+KLF)
152 LC = IQ(KQSP+LCDIR+KLC)
153 NWFREE=IQ(KQSP+LCDIR+KNFREE)
157 * Compute how many records and how many words
158 * are necessary to write array V.
164 IF(NDATA.LE.NLEFT)THEN
167 NR=(NDATA-NLEFT-1)/LREC + 1
169 IF(IRLOUT.EQ.0)NR=NR+1
171 CALL RZALLO('RZVOUT',NR,IALLOC)
172 IF(IALLOC.EQ.0)GOTO 999
174 IF(IRLOUT.EQ.0.OR.IP1.GT.LREC)THEN
192 NKEYS = IQ(KQSP+LCDIR+KNKEYS)
193 NWKEY = IQ(KQSP+LCDIR+KNWKEY)
197 * Convert input key vector to internal format
201 IKBIT1=3*I-30*IKDES-2
202 IF(JBYT(IQ(KQSP+LCDIR+KKDES+IKDES),IKBIT1,3).LT.3)THEN
205 CALL ZHTOI(KEYU(I),KEY(I),1)
209 * Search if KEY is already entered
215 LKC=LK+(NWKEY+1)*(I-1)
216 IF(IQ(KQSP+LCDIR+LKC+K).NE.KEY(K))GOTO 30
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
227 ICOLD = JBYT(IQ(KQSP+LCDIR+LCOLD+KCNCYC),21,12)
229 IKYV = IQ(KQSP+LCDIR+LKC+1)
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)
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)
248 IF(NWORDS.LE.NLEFT)THEN
251 NR=(NWORDS-NLEFT-1)/LREC + 1
253 IF(LOGLV.GE.3) WRITE(IQPRNT,10100) IP1,IR1,NWORDS,NR
254 10100 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
257 10200 FORMAT(' RZVOUT. object continues in record ',I6)
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
272 * Object must already exist if R option is given
276 IF(LOGLV.GE.-2) WRITE(IQLOG,10300)
277 10300 FORMAT(' RZVOUT. Error - object does not exist')
283 * New KEY, append to the list
286 NWFREE=NWFREE-NWKEY-1
287 IQ(KQSP+LCDIR+KNKEYS)=IQ(KQSP+LCDIR+KNKEYS)+1
293 IQ(KQSP+LCDIR+LKC+I)=KEY(I)
295 * IKYV = IQ(KQSP+LCDIR+KNKEYS)
296 IKYV = IQ(KQSP+LCDIR+LKC+1)
303 #if !defined(CERNLIB_FQXISN)
306 IF(IOPTI.NE.0)MFO(1)=2
307 IF(IOPTB.NE.0)MFO(1)=1
308 IF(IOPTH.NE.0)MFO(1)=5
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
318 IROUT=IQ(KQSP+LTOP+KIROUT)
321 CALL RZIODO(LUN,LREC,IROUT,IQ(KQSP+LROUT+1),1)
322 #if defined(CERNLIB_QMVAX)
323 IF(IRELAT.NE.0)UNLOCK(UNIT=LUN)
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
341 NWFREE= NWFREE-KLCYCL
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
356 + CALL SBYT(IR2,IQ(KQSP+LCDIR+LC+KSRCYC),17,16)
357 CALL SBYT(IR1,IQ(KQSP+LCDIR+LC+KFRCYC),17,16)
359 IF (NLEFT.LT.NDATA) THEN
360 IQ(KQSP+LCDIR+LC+KSRCYC) = IR2
362 IQ(KQSP+LCDIR+LC+KSRCYC) = 0
364 IQ(KQSP+LCDIR+LC+KFRCYC) = IR1
365 IQ(KQSP+LCDIR+LC+KKYCYC) = IKYV
369 * Update internal pointers in the directory
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
386 IQ(KQSP+LCDIR+KWUSED)=NWUSED
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
396 IQUEST(9)=IQ(KQSP+LCDIR+KQUOTA)-IQ(KQSP+LCDIR+KRUSED)
400 IF(IOPTR.EQ.0.AND.NR.GT.0)THEN
401 CALL RZUSED(NR,IALLOC)
404 * Restore last record written if required
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
411 CALL RZIODO(LUN,LREC,IRLOUT,IQ(KQSP+LROUT+1),1)
412 IF(IQUEST(1).NE.0)GOTO 999