MINICERN/packlib/zebra/rz/rzout.F

   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