]> git.uio.no Git - u/mrichter/AliRoot.git/blame - MINICERN/packlib/zebra/rz/rzdelk.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 / rzdelk.F
CommitLineData
fe4da5cc 1*
2* $Id$
3*
4* $Log$
5* Revision 1.2 1996/04/24 17:26:45 mclareni
6* Extend the include file cleanup to dzebra, rz and tq, and also add
7* dependencies in some cases.
8*
9* Revision 1.1.1.1 1996/03/06 10:47:23 mclareni
10* Zebra
11*
12*
13#include "zebra/pilot.h"
14 SUBROUTINE RZDELK(KEYU,ICYCLE,CHOPT)
15*
16************************************************************************
17*
18* To delete one or all keys in the CWD
19* Input:
20* KEYU Key array of dimension NWKEY (see RZMDIR)
21* ICYCLE Cycle number of the key to be deleted
22* ICYCLE > highest cycle number means delete the highest cycle
23* ICYCLE = 0 means delete the lowest cycle
24* ICYCLE = -1, -2,... means delete the highest cycle -1, -2,...
25* CHOPT Character variable specifying the options selected.
26* default
27* Delete the explicitly specified cycle ICYCLE only.
28* If cycle ICYCLE does not exist, no action is taken.
29* 'C' Delete ALL cycles corresponding to key (ICYCLE not used)
30* 'S' Delete all cycles smaller then cycle ICYCLE.
31* 'K' Delete ALL cycles for all Keys (KEYU,ICYCLE not used )
32*
33* Called by <USER>
34*
35* Author : R.Brun DD/US/PD
36* Written : 20.04.86
37* Last mod: 16.04.93 JDS. Return codes, deletion of objects at beginning
38* of cycles structure
39* : 04.03.94 S.Banerjee (Change in cycle structure)
40* : 23.03.95 J.Shiers - key # in cycles block is KEY(1)
41* IQUEST(1) = 0: ok
42* IQUEST(1) = 1: specified object not found
43* IQUEST(1) = 2: directory is empty
44* IQUEST(1) = 3: no RZ control bank (LQRS=0)
45* IQUEST(1) = 4: no write permission
46* IQUEST(1) =11: key/cycle discrepency
47*
48************************************************************************
49#include "zebra/zunit.inc"
50#include "zebra/rzcl.inc"
51#include "zebra/rzclun.inc"
52#include "zebra/rzk.inc"
53#include "zebra/rzckey.inc"
54#include "zebra/rzcycle.inc"
55 CHARACTER*(*) CHOPT
56 DIMENSION KEYU(*)
57 DIMENSION IOPTV(3)
58 EQUIVALENCE (IOPTC,IOPTV(1)), (IOPTS,IOPTV(2))
59 EQUIVALENCE (IOPTK,IOPTV(3))
60*
61*-----------------------------------------------------------------------
62*
63#include "zebra/q_jbyt.inc"
64*
65 IQUEST(1) = 0
66 IQWARN = 0
67 CALL UOPTC(CHOPT,'CSK',IOPTV)
68*
69* Check if write permission
70*
71 IF(LQRS.EQ.0) THEN
72 IQUEST(1) = 3
73 GOTO 230
74 ENDIF
75
76 IFLAG=1
77 CALL RZMODS('RZDELK',IFLAG)
78 IF(IFLAG.NE.0) THEN
79 IQUEST(1) = 4
80 GOTO 230
81 ENDIF
82*
83 LD=IQ(KQSP+LCDIR+KLD)
84 LK=IQ(KQSP+LCDIR+KLK)
85 LF=IQ(KQSP+LCDIR+KLF)
86 LC=IQ(KQSP+LCDIR+KLC)
87 LE=IQ(KQSP+LCDIR+KLE)
88 NKEYS =IQ(KQSP+LCDIR+KNKEYS)
89 NWKEY =IQ(KQSP+LCDIR+KNWKEY)
90 IF(NKEYS.EQ.0)GOTO 220
91*
92* Look for cycles marked for deletion by a previous call
93* Set IQUEST(2) to warn application to rebuild bit map
94*
95 DO 10 LKC=LC,LE-KLCYCL+1,KLCYCL
96 IF(IQ(KQSP+LCDIR+LKC).EQ.-1)GOTO 20
97 10 CONTINUE
98 GOTO 30
99 20 IQWARN = 1
100 30 CONTINUE
101*
102 NPUOLD=0
103 IF(LPURG.NE.0)THEN
104 NPURG=IQ(KQSP+LPURG+1)
105 DO 40 I=1,NPURG
106 NPUOLD=NPUOLD+IQ(KQSP+LPURG+2*I+1)-IQ(KQSP+LPURG+2*I)+1
107 40 CONTINUE
108 ENDIF
109*
110* Option K. delete all keys
111*
112 IF(IOPTK.NE.0)THEN
113 DO 50 LKC=LC,LE-KLCYCL+1,KLCYCL
114 IF (KVSCYC.EQ.0) THEN
115 IR1 = JBYT(IQ(KQSP+LCDIR+LKC+KFRCYC),17,16)
116 IP1 = JBYT(IQ(KQSP+LCDIR+LKC+KORCYC), 1,16)
117 NW = JBYT(IQ(KQSP+LCDIR+LKC+KNWCYC), 1,20)
118 IR2 = JBYT(IQ(KQSP+LCDIR+LKC+KSRCYC),17,16)
119 ELSE
120 IR1 = IQ(KQSP+LCDIR+LKC+KFRCYC)
121 IP1 = JBYT(IQ(KQSP+LCDIR+LKC+KORCYC), 1,20)
122 NW = IQ(KQSP+LCDIR+LKC+KNWCYC)
123 IR2 = IQ(KQSP+LCDIR+LKC+KSRCYC)
124 ENDIF
125 NLEFT=LREC-IP1+1
126 IF(NW.LE.NLEFT)THEN
127 NR=0
128 ELSE
129 NR=(NW-NLEFT-1)/LREC+1
130 ENDIF
131 IF(IR2.EQ.IR1+1)THEN
132 CALL RZPURF(NR+1,IR1)
133 ELSE
134 CALL RZPURF(1,IR1)
135 IF(NR.NE.0)CALL RZPURF(NR,IR2)
136 ENDIF
137 50 CONTINUE
138 LF=LK
139 LC=LE+1
140 NRD=IQ(KQSP+LCDIR+LD)
141 IQ(KQSP+LCDIR+KRUSED) =NRD
142 IQ(KQSP+LCDIR+KWUSED) =NRD*LREC
143 IQ(KQSP+LCDIR+KMEGA) =0
144 IQ(KQSP+LCDIR+KIP1) =1
145 IQ(KQSP+LCDIR+KNFREE) =LC-LF
146 IQ(KQSP+LCDIR+KLF) =LF
147 IQ(KQSP+LCDIR+KLC) =LC
148 IQ(KQSP+LCDIR+KNKEYS) =0
149 GOTO 240
150 ENDIF
151*
152* Search KEY and CYCLE
153*
154 DO 60 I=1,NWKEY
155 IKDES=(I-1)/10
156 IKBIT1=3*I-30*IKDES-2
157 IF(JBYT(IQ(KQSP+LCDIR+KKDES+IKDES),IKBIT1,3).LT.3)THEN
158 KEY(I)=KEYU(I)
159 ELSE
160 CALL ZHTOI(KEYU(I),KEY(I),1)
161 ENDIF
162 60 CONTINUE
163 DO 80 I=1,NKEYS
164 DO 70 K=1,NWKEY
165 LKC=LK+(NWKEY+1)*(I-1)
166 IF(IQ(KQSP+LCDIR+LKC+K).NE.KEY(K))GOTO 80
167 70 CONTINUE
168 LCYC =IQ(KQSP+LCDIR+LKC)
169 LCPRE =LCYC
170 LKK =LKC
171 IF (KVSCYC.NE.0) THEN
172* IF (IQ(KQSP+LCDIR+LCYC+KKYCYC).NE.I) GO TO 250
173 IF (IQ(KQSP+LCDIR+LCYC+KKYCYC).NE.
174 + IQ(KQSP+LCDIR+LKC+1)) GO TO 250
175 ENDIF
176 ICTOP =JBYT(IQ(KQSP+LCDIR+LCYC+KCNCYC),21,12)
177 KCYCLE=ICYCLE
178 IF(KCYCLE.GT.ICTOP)KCYCLE=ICTOP
179 GOTO 90
180 80 CONTINUE
181 GOTO 210
182*
183* Do we keep this cycle ?
184*
185 90 IF (KVSCYC.EQ.0) THEN
186 LCOLD = JBYT(IQ(KQSP+LCDIR+LCYC+KPPCYC), 1,16)
187 ELSE
188 LCOLD = IQ(KQSP+LCDIR+LCYC+KPPCYC)
189 ENDIF
190 IDEL=0
191 ICY =JBYT(IQ(KQSP+LCDIR+LCYC+KCNCYC),21,12)
192 IF(KCYCLE.EQ.ICY.AND.IOPTS.EQ.0)IDEL=1
193 IF(IOPTC.NE.0)IDEL=1
194 IF(IOPTK.NE.0)IDEL=1
195 IF(IOPTS.NE.0)THEN
196 IF(ICY.LT.ICYCLE)IDEL=1
197 ENDIF
198 IF(ICYCLE.EQ.0.AND.LCOLD.EQ.0)IDEL=1
199 IF(ICYCLE.LT.0)THEN
200 IF(ICY.EQ.ICTOP-ICYCLE)IDEL=1
201 ENDIF
202*
203* Mark all records that can be purged in first pass
204*
205 IF(IDEL.NE.0)THEN
206 IF(ICY.EQ.ICTOP)THEN
207 IQ(KQSP+LCDIR+LKK)=LCOLD
208 ELSE
209 IF(LCOLD.EQ.0.AND.IOPTC.NE.0)THEN
210 IQ(KQSP+LCDIR+LKK)=0
211 IQ(KQSP+LCDIR+LCPRE)=-1
212 ELSE
213 CALL SBYT(LCOLD,IQ(KQSP+LCDIR+LCPRE),1,16)
214 ENDIF
215 ENDIF
216 IF (KVSCYC.EQ.0) THEN
217 IR1 = JBYT(IQ(KQSP+LCDIR+LCYC+KFRCYC),17,16)
218 IP1 = JBYT(IQ(KQSP+LCDIR+LCYC+KORCYC), 1,16)
219 NW = JBYT(IQ(KQSP+LCDIR+LCYC+KNWCYC), 1,20)
220 IR2 = JBYT(IQ(KQSP+LCDIR+LCYC+KSRCYC),17,16)
221 ELSE
222 IR1 = IQ(KQSP+LCDIR+LCYC+KFRCYC)
223 IP1 = JBYT(IQ(KQSP+LCDIR+LCYC+KORCYC), 1,20)
224 NW = IQ(KQSP+LCDIR+LCYC+KNWCYC)
225 IR2 = IQ(KQSP+LCDIR+LCYC+KSRCYC)
226 ENDIF
227 IRL =0
228 NWL =0
229 NLEFT=LREC-IP1+1
230 NW1=NW
231 IF(NW1.GE.NLEFT)NW1=NLEFT
232 IF(IR2.NE.0)THEN
233 NR=(NW-NW1-1)/LREC+1
234 IF(NR.GT.1) CALL RZPURF(NR-1,IR2)
235 IRL=IR2+NR-1
236 NWL=NW-NW1-(NR-1)*LREC
237 ENDIF
238 IF(NW1.EQ.LREC)THEN
239 CALL RZPURF(1,IR1)
240 IR1=0
241 ENDIF
242 IF(NWL.EQ.LREC)THEN
243 CALL RZPURF(1,IRL)
244 IRL=0
245 ENDIF
246 IRLOUT=IQ(KQSP+LCDIR+KRLOUT)
247 IF(IRL.EQ.IRLOUT.AND.NWL+1.EQ.IQ(KQSP+LCDIR+KIP1))THEN
248 CALL RZPURF(1,IRL)
249 IRL=0
250 ENDIF
251 IQ(KQSP+LCDIR+LCYC)=-1
252 IQ(KQSP+LCDIR+LCYC+1)=IR1
253 IQ(KQSP+LCDIR+LCYC+2)=IRL
254 IQ(KQSP+LCDIR+LCYC+3)=NWL
255 IF(IR1.NE.0)CALL SBYT(NW1,IQ(KQSP+LCDIR+LCYC+3),21,12)
256 ELSE
257 LCPRE=LCYC
258 ENDIF
259*
260 IF(LCOLD.NE.0.AND.LCOLD.NE.LCYC)THEN
261 IF(KCYCLE.LT.ICY.OR.IOPTS.NE.0.OR.IOPTK.NE.0.OR.IOPTC.NE.0)THEN
262 LCYC=LCOLD
263 GOTO 90
264 ENDIF
265 ENDIF
266*
267* Now loop on all purged cycles to find complete records
268* purged
269*
270 DO 130 LKC=LC,LE-KLCYCL+1,KLCYCL
271 IF(IQ(KQSP+LCDIR+LKC).NE.-1)GOTO 130
272 IR1=IQ(KQSP+LCDIR+LKC+1)
273 IRL=IQ(KQSP+LCDIR+LKC+2)
274 IF(IR1.NE.0)THEN
275 DO 100 LKC1=LC,LE-KLCYCL+1,KLCYCL
276 IF(IQ(KQSP+LCDIR+LKC1).EQ.-1)GOTO 100
277 IF (KVSCYC.EQ.0) THEN
278 KR1 = JBYT(IQ(KQSP+LCDIR+LKC1+KFRCYC),17,16)
279 KP1 = JBYT(IQ(KQSP+LCDIR+LKC1+KORCYC), 1,16)
280 NW = JBYT(IQ(KQSP+LCDIR+LKC1+KNWCYC), 1,20)
281 KR2 = JBYT(IQ(KQSP+LCDIR+LKC1+KSRCYC),17,16)
282 ELSE
283 KR1 = IQ(KQSP+LCDIR+LKC1+KFRCYC)
284 KP1 = JBYT(IQ(KQSP+LCDIR+LKC1+KORCYC), 1,20)
285 NW = IQ(KQSP+LCDIR+LKC1+KNWCYC)
286 KR2 = IQ(KQSP+LCDIR+LKC1+KSRCYC)
287 ENDIF
288 KRL =0
289 NLEFT=LREC-KP1+1
290 NW1=NW
291 IF(NW1.GE.NLEFT)NW1=NLEFT
292 IF(KR2.NE.0)THEN
293 NR=(NW-NW1-1)/LREC+1
294 KRL=KR2+NR-1
295 ENDIF
296 IF(KR1.EQ.IR1.OR.KRL.EQ.IR1)GOTO 110
297 100 CONTINUE
298 CALL RZPURF(1,IR1)
299 ENDIF
300*
301 110 IF(IRL.NE.0)THEN
302 DO 120 LKC1=LC,LE-KLCYCL+1,KLCYCL
303 IF(IQ(KQSP+LCDIR+LKC1).EQ.-1)GOTO 120
304 IF (KVSCYC.EQ.0) THEN
305 KR1 = JBYT(IQ(KQSP+LCDIR+LKC1+KFRCYC),17,16)
306 KP1 = JBYT(IQ(KQSP+LCDIR+LKC1+KORCYC), 1,16)
307 NW = JBYT(IQ(KQSP+LCDIR+LKC1+KNWCYC), 1,20)
308 KR2 = JBYT(IQ(KQSP+LCDIR+LKC1+KSRCYC),17,16)
309 ELSE
310 KR1 = IQ(KQSP+LCDIR+LKC1+KFRCYC)
311 KP1 = JBYT(IQ(KQSP+LCDIR+LKC1+KORCYC), 1,20)
312 NW = IQ(KQSP+LCDIR+LKC1+KNWCYC)
313 KR2 = IQ(KQSP+LCDIR+LKC1+KSRCYC)
314 ENDIF
315 KRL =0
316 NLEFT=LREC-KP1+1
317 NW1=NW
318 IF(NW1.GE.NLEFT)NW1=NLEFT
319 IF(KR2.NE.0)THEN
320 NR=(NW-NW1-1)/LREC+1
321 KRL=KR2+NR-1
322 ENDIF
323 IF(KR1.EQ.IRL.OR.KRL.EQ.IRL)GOTO 130
324 120 CONTINUE
325 CALL RZPURF(1,IRL)
326 ENDIF
327 130 CONTINUE
328*
329* Garbage collection on cycles area + relocation
330*
331 LKC3=LE-KLCYCL+1
332 140 IF(LKC3.LT.LC)GOTO 190
333*
334* Found a deleted object. Now look for previous undeleted object
335*
336 IF(IQ(KQSP+LCDIR+LKC3).EQ.-1)THEN
337
338 LKC3=LKC3+KLCYCL
339 LKC2=LKC3-2*KLCYCL
340*
341* First object?
342*
343 IF(LKC2.LT.LC) THEN
344 LC = LKC3
345 GOTO 190
346 ENDIF
347
348 150 IF(IQ(KQSP+LCDIR+LKC2).NE.-1)THEN
349 LKC2=LKC2+KLCYCL
350 LKC1=LKC2-2*KLCYCL
351 IF(LKC1.LT.LC)LKC1=LC
352 160 IF(IQ(KQSP+LCDIR+LKC1).EQ.-1)THEN
353 IF(LKC1.GT.LC .OR.
354 + (LKC1.EQ.LC.AND.LKC2.NE.LC))LKC1=LKC1+KLCYCL
355 ELSE
356 IF(LKC1.GT.LC)THEN
357 LKC1=LKC1-KLCYCL
358 GOTO 160
359 ENDIF
360 ENDIF
361*
362 NPUSH=LKC3-LKC2
363*
364* Update pointers in cycles block
365*
366 DO 170 LKC=LC,LKC2-KLCYCL,KLCYCL
367 IF(IQ(KQSP+LCDIR+LKC).NE.-1)THEN
368 IF (KVSCYC.EQ.0) THEN
369 LCOLD = JBYT(IQ(KQSP+LCDIR+LKC+KPPCYC),1,16)
370 ELSE
371 LCOLD = IQ(KQSP+LCDIR+LKC+KPPCYC)
372 ENDIF
373 IF(LCOLD.GE.LKC1.AND.LCOLD.LT.LKC2)THEN
374 LCOLD=LCOLD+NPUSH
375 IF (KVSCYC.EQ.0) THEN
376 CALL SBYT(LCOLD,IQ(KQSP+LCDIR+LKC+KPPCYC),1,16)
377 ELSE
378 IQ(KQSP+LCDIR+LKC+KPPCYC) = LCOLD
379 ENDIF
380 ENDIF
381 ENDIF
382 170 CONTINUE
383*
384* Update pointers from KEYS block to CYCLES block
385*
386 DO 180 IK=1,NKEYS
387 LCYC=IQ(KQSP+LCDIR+LK+(NWKEY+1)*(IK-1))
388 IF(LCYC.GE.LKC1.AND.LCYC.LT.LKC2)THEN
389 IQ(KQSP+LCDIR+LK+(NWKEY+1)*(IK-1))=
390 + IQ(KQSP+LCDIR+LK+(NWKEY+1)*(IK-1))+NPUSH
391 ENDIF
392 180 CONTINUE
393*
394* Squeeze out deleted cycles
395*
396 CALL UCOPY2(IQ(KQSP+LCDIR+LKC1),IQ(KQSP+LCDIR+LKC1+NPUSH),
397 + LKC2-LKC1)
398 LKC3=LKC1+NPUSH
399 LKC2=LKC1-KLCYCL
400*
401* Only deleted objects before this block?
402*
403 IF(IQ(KQSP+LCDIR+LKC2).EQ.-1.AND.LKC2.EQ.LC) THEN
404 LC = LKC3
405 GOTO 190
406 ENDIF
407
408 IF(LKC1.NE.LC)GOTO 150
409 LC=LC+NPUSH
410 GOTO 190
411*
412 ELSE
413 LKC2=LKC2-KLCYCL
414*
415* Only deleted objects before this block?
416*
417 IF(IQ(KQSP+LCDIR+LKC2).EQ.-1.AND.LKC2.EQ.LC) THEN
418 LC = LKC3
419 GOTO 190
420 ENDIF
421
422 IF(LKC2.GE.LC)GOTO 150
423
424 ENDIF
425 ELSE
426 LKC3=LKC3-KLCYCL
427 GOTO 140
428 ENDIF
429*
430* Remove KEY from K area if only one cycle
431*
432 190 CONTINUE
433 IF(IQ(KQSP+LCDIR+LKK).EQ.0)THEN
434 IF(LKK+NWKEY+1.LT.LF)THEN
435 CALL UCOPY2(IQ(KQSP+LCDIR+LKK+NWKEY+1),
436 + IQ(KQSP+LCDIR+LKK),LF-LKK)
437 ENDIF
438 LF=LF-NWKEY-1
439 IQ(KQSP+LCDIR+KNFREE)=IQ(KQSP+LCDIR+KNFREE)+NWKEY+1
440 IQ(KQSP+LCDIR+KLF)=LF
441 IQ(KQSP+LCDIR+KNKEYS)=IQ(KQSP+LCDIR+KNKEYS)-1
442 IF(IQ(KQSP+LCDIR+KNKEYS).EQ.0)LC=LE+1
443 ENDIF
444*
445* Reset internal pointers
446*
447 NPUNEW=0
448 IF(LPURG.NE.0)THEN
449 NPURG=IQ(KQSP+LPURG+1)
450 DO 200 I=1,NPURG
451 NPUNEW=NPUNEW+IQ(KQSP+LPURG+2*I+1)-IQ(KQSP+LPURG+2*I)+1
452 200 CONTINUE
453 ENDIF
454 NPU=NPUNEW-NPUOLD
455 IQUEST( 9)=IQ(KQSP+LCDIR+KQUOTA)-IQ(KQSP+LCDIR+KRUSED)+NPU
456 IQUEST(11)=(LC-IQ(KQSP+LCDIR+KLC))/KLCYCL
457 IQUEST(12)=NPU*LREC
458 IQUEST(13)=NPU
459*
460 IQ(KQSP+LCDIR+KRUSED)=IQ(KQSP+LCDIR+KRUSED)-NPU
461 NWP=NPU*LREC
462 NMEGA=NWP/1000000
463 IQ(KQSP+LCDIR+KMEGA)=IQ(KQSP+LCDIR+KMEGA)-NMEGA
464 NWP=NWP-1000000*NMEGA
465 IQ(KQSP+LCDIR+KWUSED)=IQ(KQSP+LCDIR+KWUSED)-NWP
466 IQ(KQSP+LCDIR+KNFREE)=IQ(KQSP+LCDIR+KNFREE)+LC-IQ(KQSP+LCDIR+KLC)
467 IQ(KQSP+LCDIR+KLC)=LC
468 GOTO 240
469*
470* KEY not found
471*
472 210 IF(JBYT(IQ(KQSP+LTOP),15,3)-3.GE.-2) WRITE(IQLOG,10000)
47310000 FORMAT(' RZDELK. Key not found')
474 IQUEST(1)=1
475 IQUEST(2)=IQWARN
476 RETURN
477
478 220 IF(JBYT(IQ(KQSP+LTOP),15,3)-3.GE.-2) WRITE(IQLOG,10100)
47910100 FORMAT(' RZDELK. directory is empty')
480 IQUEST(1)=2
481 IQUEST(2)=IQWARN
482 RETURN
483*
484 230 IQUEST(2)=IQWARN
485 RETURN
486
487 240 IQUEST(2)=IQWARN
488 RETURN
489
490 250 IF(JBYT(IQ(KQSP+LTOP),15,3)-3.GE.-2) WRITE(IQLOG,10100)
49110200 FORMAT(' RZDELK. mismatch in key/cycle pointing')
492 IQUEST(1)=11
493 IQUEST(2)=IQWARN
494 RETURN
495 END