MINICERN/packlib/zebra/rz/rzvout.F

   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)
  99 10000    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
 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)
 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)
 277 10300    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