MINICERN/packlib/zebra/rz/rzfile.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.5  1998/09/25 09:33:35  mclareni
   6 * Modifications for the Mklinux port flagged by CERNLIB_PPC
   7 *
   8 * Revision 1.4  1997/09/02 15:16:11  mclareni
   9 * WINNT corrections
  10 *
  11 * Revision 1.3  1997/03/14 17:21:19  mclareni
  12 * WNT mods
  13 *
  14 * Revision 1.2  1996/04/24 17:26:50  mclareni
  15 * Extend the include file cleanup to dzebra, rz and tq, and also add
  16 * dependencies in some cases.
  17 *
  18 * Revision 1.1.1.1  1996/03/06 10:47:23  mclareni
  19 * Zebra
  20 *
  21 *
  22 #include "zebra/pilot.h"
  23       SUBROUTINE RZFILE(LUNIN,CHDIR,CHOPT)
  24 *
  25 ************************************************************************
  26 *
  27 *           Routine to access an already existing RZ file
  28 *           To create a new RZ file routine RZMAKE should be used
  29 * Input:
  30 *   LUNP    Logical unit number associated with  the RZ file.   A FORTRAN
  31 *           OPEN statement must precede the call to RZFILE.
  32 *           Starting address of the memory area which will contain the RZ
  33 *           information ('M' option)
  34 *   CHDIR   Character variable specifying  the name of the  top directory
  35 *           to be associated with unit LUN.
  36 *   CHOPT   Character variable specifying the selected options.
  37 *           medium
  38 *          default
  39 *                   Disk
  40 *             'M'   Memory mode
  41 *                   In this case space has already been allocated starting
  42 *                   at address LUNP.
  43 *           other
  44 *             'U'   UPDATE mode  default is READ mode only
  45 *             'S'   SHARED mode  default is exclusive access
  46 *             '1'   UPDATE mode  with only one user (no LOCKs required)
  47 *             'L'   Show all locked directories and lock-ids
  48 *             'D'   Reset LOCKing word in first record
  49 *             'C'   C I/O
  50 *             'H'   Hook user routine to RZIODO
  51 *             'X'   Exchange mode file
  52 *
  53 *             'B'   Rebuild bit map of file occupancy from file itself
  54 *
  55 * Called by <USER>
  56 *
  57 *  Author  : R.Brun DD/US/PD
  58 *  Written : 07.04.86
  59 *  Last mod: 22.09.94 JDS - include Z=RZCYCLE and call to RZVCYC
  60 *            06.07.95 JDS - return RZ file version in IQUEST(13)
  61 *
  62 ************************************************************************
  63 *
  64 #include "zebra/zunit.inc"
  65 #include "zebra/zstate.inc"
  66 #include "zebra/rzcl.inc"
  67 #include "zebra/rzdir.inc"
  68 #include "zebra/rzclun.inc"
  69 #include "zebra/rzk.inc"
  70 #include "zebra/rzckey.inc"
  71 #include "zebra/rzcycle.inc"
  72 #include "zebra/rzbuff.inc"
  73 #if defined(CERNLIB_QMVAX)
  74       CHARACTER*16 CHORG
  75 #endif
  76       CHARACTER    CHOPT*(*),CHDIR*(*)
  77       CHARACTER*16 CHTOP
  78       DIMENSION    IOPTV(10)
  79       EQUIVALENCE (IOPTM,IOPTV(1)), (IOPTU,IOPTV(2))
  80       EQUIVALENCE (IOPTS,IOPTV(3)), (IOPTL,IOPTV(4))
  81       EQUIVALENCE (IOPT1,IOPTV(5)), (IOPTD,IOPTV(6))
  82       EQUIVALENCE (IOPTC,IOPTV(7)), (IOPTX,IOPTV(8))
  83       EQUIVALENCE (IOPTB,IOPTV(9)), (IOPTH,IOPTV(10))
  84 *
  85 *-----------------------------------------------------------------------
  86 *
  87 #include "zebra/q_jbit.inc"
  88 #include "zebra/q_jbyt.inc"
  89
  90       IQUEST(1)=0
  91       LOGLV = MIN(NQLOGD,4)
  92       LOGLV = MAX(LOGLV,-3)
  93       LUNSA = LUN
  94       LUNP  = LUNIN
  95 *
  96 *          Save existing material (if any)
  97 *
  98       CALL RZSAVE
  99 *
 100       CALL UOPTC (CHOPT,'MUSL1DCXBH',IOPTV)
 101 #if !defined(CERNLIB_QCFIO)
 102 *SELF,IF=-QMCRY,IF=-QMVAX,IF=-QMCV64,IF=-QMAPO,IF=-QMAPO9,IF=-QMUIX,IF=-QMDOS.
 103       IF(IOPTC.NE.0) THEN
 104          WRITE(IQPRNT,*) 'RZFILE. option C ignored - valid only ',
 105      +      'for MSDOS, Unix and VMS systems'
 106          IOPTC = 0
 107        ENDIF
 108 #endif
 109       IRELAT=0
 110       IMODEC=IOPTC
 111       IMODEH=IOPTH
 112       IMODEX=IOPTX
 113 #if (defined(CERNLIB_QMLNX) && !defined(CERNLIB_PPC))
 114 C     RZfile with Exchange mode for NonPPC-LINUX
 115 *     IMODEX=1
 116 #endif
 117 *
 118 *     Take LRECL and LUNP from IQUEST(10-11) in case of C I/O
 119 *
 120       IF(IOPTC.NE.0) THEN
 121          LRECP = IQUEST(10)
 122          LUNP  = IQUEST(11)
 123       ENDIF
 124 *
 125 *     Take LRECL and address of user routine from IQUEST(10-11)
 126 *     in case of user I/O routine
 127 *
 128       IF(IOPTH.NE.0) THEN
 129          LRECP  = IQUEST(10)
 130          LUN    = IQUEST(11)
 131          LUSER  = LUNIN
 132       ENDIF
 133 *
 134 *            Find record length (as specified in the OPEN statement)
 135 *
 136 *          A, Memory option. LUN contains the buffer address
 137 *                            and the value of LUNP is the block length
 138 *
 139       IF(IOPTM.NE.0)THEN
 140          LRECP=1024
 141          LUN=-99
 142       ELSEIF(IOPTH.EQ.0) THEN
 143 *
 144 *          B, Standard option DISK. Use information as specified
 145 *             in the Fortran OPEN statement
 146 *
 147 #if defined(CERNLIB_QMVAX)
 148          IF(IOPTC.EQ.0) THEN
 149             INQUIRE(UNIT=LUNP,ORGANIZATION=CHORG)
 150             IF(CHORG.EQ.'RELATIVE')IRELAT=1
 151          ENDIF
 152 #endif
 153 *
 154          IZRECL=LRECP
 155          CALL RZIODO(LUNP,50,2,ITEST,1)
 156 *
 157 *      If option X not specified, determine mode (eXchange, native)
 158 *      from file
 159 *
 160          IF(IOPTX.EQ.0) THEN
 161 #if defined(CERNLIB_QMVAX)||defined(CERNLIB_QMVMI)||defined(CERNLIB_QMDOS)||(defined(CERNLIB_QMLNX) && !defined(CERNLIB_PPC))||defined(CERNLIB_WINNT)
 162             CALL VXINVB(ITEST(9),1)
 163 #endif
 164             IF(JBIT(ITEST(9),12).NE.0)THEN
 165                IMODEX=1
 166 #if defined(CERNLIB_QMVAX)||defined(CERNLIB_QMVMI)||defined(CERNLIB_QMDOS)||(defined(CERNLIB_QMLNX) && !defined(CERNLIB_PPC))||defined(CERNLIB_WINNT)
 167                CALL RZIODO(LUNP,50,2,ITEST,1)
 168             ELSE
 169                CALL VXINVB(ITEST(9),1)
 170 #endif
 171             ENDIF
 172          ENDIF
 173
 174          IF(IQUEST(1).NE.0)GO TO 30
 175          LB=ITEST(KLB)
 176          IF(LB.GT.48)CALL RZIODO(LUNP,LB+6,2,ITEST,1)
 177          IF(LB.GT.100)THEN
 178             IF(LOGLV.GE.-1) WRITE(IQLOG,10000)
 179 10000       FORMAT(' RZFILE. WARNING!! Top directory is big')
 180          ENDIF
 181          LRECP=ITEST(LB+1)
 182 #if defined(CERNLIB_QMALT)||defined(CERNLIB_QMAPO)||defined(CERNLIB_QMDOS)||defined(CERNLIB_WINNT)
 183          IF(IOPTC.EQ.0.AND.IOPTH.EQ.0) THEN
 184             INQUIRE(UNIT=LUNP,RECL=LRECL)
 185 * DEC Fortran takes "longword" units
 186 #endif
 187 #if (defined(CERNLIB_QFDEC))&&(defined(CERNLIB_QMDOS))
 188             IF(LRECP.NE.LRECL)THEN
 189 #endif
 190 #if (defined(CERNLIB_QMALT)||defined(CERNLIB_QMAPO)||defined(CERNLIB_QMDOS)||defined(CERNLIB_WINNT))&&(!defined(CERNLIB_QFDEC))
 191             IF(LRECP.NE.LRECL/4)THEN
 192 #endif
 193 #if defined(CERNLIB_QMALT)||defined(CERNLIB_QMAPO)||defined(CERNLIB_QMDOS)||defined(CERNLIB_WINNT)
 194                IQUEST(1)=1
 195                IF(LOGLV.GE.-2) WRITE(IQLOG,10100)LUNP,LRECP,LRECL/4
 196 10100          FORMAT(' RZFILE. Unit ',I6,'RECL on file ',I5,
 197      +                ' incompatible with RECL in OPEN =',I5)
 198                GO TO 30
 199             ENDIF
 200          ENDIF
 201 #endif
 202          LUN=LUNP
 203          IQUEST(1)=0
 204       ENDIF
 205 *
 206       IF(LOGLV.GE.0) WRITE(IQLOG,10200) LUN,LRECP,CHOPT
 207 10200 FORMAT(' RZFILE. UNIT ',I6,' Initializing with LREC=',I6,
 208      +', OPT= ',A)
 209       CALL MZSDIV (0,-7)
 210 *
 211 *           Check if LUN not already defined
 212 *
 213       LRZ=LQRS
 214    10 IF(LRZ.NE.0)THEN
 215          IF(IQ(KQSP+LRZ-5).EQ.LUN)THEN
 216             IQUEST(1)=1
 217             IF(LOGLV.GE.-2) WRITE(IQLOG,10300)
 218 10300       FORMAT(' RZFILE. Unit is already in use')
 219             LUN=LUNSA
 220             GO TO 30
 221          ELSE
 222             LRZ=LQ(KQSP+LRZ)
 223             GO TO 10
 224          ENDIF
 225       ENDIF
 226 *
 227 *            First call to RZFILE, create link area
 228 *
 229       IF(LQRS.EQ.0)THEN
 230          CALL MZLINK(JQPDVS,'RZCL',LTOP,LTOP,LFROM)
 231          CALL MZBOOK (JQPDVS,LRZ0,LQRS,1,'RZ0 ',2,2,36,2,0)
 232          IQ(KQSP+LRZ0-5)=0
 233          ISAVE = 1
 234          NHPWD = 0
 235          CALL VBLANK(IHPWD,2)
 236       ENDIF
 237       NCHD  = LEN(CHDIR)
 238       IF(NCHD.GT.16)NCHD=16
 239       CHTOP = CHDIR(1:NCHD)
 240 *
 241 *            Create control bank
 242 *
 243       CALL MZBOOK(JQPDVS,LTOP,LQRS,1,'RZ  ',10,9,LRECP,2,0)
 244 *
 245 *            Disk or memory
 246 *
 247       IF(IOPTM.EQ.0)THEN
 248          IQ(KQSP+LTOP-5) = LUN
 249 *
 250 *            C I/O?
 251 *
 252          IF(IOPTC.NE.0) CALL SBIT1(IQ(KQSP+LTOP),5)
 253 *
 254 *            user I/O?
 255 *
 256          IF(IOPTH.NE.0) THEN
 257             CALL SBIT1(IQ(KQSP+LTOP),6)
 258             CALL SBYT(LUSER,IQ(KQSP+LTOP),7,7)
 259          ENDIF
 260       ELSE
 261          NMEM=IQ(KQSP+LRZ0)+1
 262          IQ(KQSP+LRZ0)=NMEM
 263          IQ(KQSP+LTOP-5)=-NMEM
 264          IF(2*NMEM.GT.IQ(KQSP+LRZ0-1))THEN
 265             CALL MZPUSH(JQPDVS,LRZ0,0,10,' ')
 266          ENDIF
 267          IQ(KQSP+LRZ0+2*NMEM-1)=LOCF(LUNP)-LOCF(IQ(1))+1
 268          IQ(KQSP+LRZ0+2*NMEM  )=LRECP
 269          LUN=-NMEM
 270       ENDIF
 271 *
 272 *            Read 1st record of directory
 273 *
 274       CALL RZIODO(LUN,LRECP,2,IQ(KQSP+LTOP+1),1)
 275       IF(IQUEST(1).NE.0)GO TO 30
 276       LD   = IQ(KQSP+LTOP+KLD)
 277       LB   = IQ(KQSP+LTOP+KLB)
 278       LREC = IQ(KQSP+LTOP+LB+1)
 279       NRD  = IQ(KQSP+LTOP+LD)
 280 #if defined(CERNLIB_FQXISN)
 281 *
 282 *     Set exchange mode bit
 283 *
 284       CALL SBIT1(IQ(KQSP+LTOP+KPW1+2),12)
 285 #endif
 286       IMODEX=JBIT(IQ(KQSP+LTOP+KPW1+2),12)
 287 *
 288 *            Increase size of control bank if required
 289 *            and read all records for top directory
 290 *
 291       NPUSH=NRD*LREC-LRECP
 292       IF(NPUSH.NE.0)CALL MZPUSH(JQPDVS,LTOP,0,NPUSH,'I')
 293       DO 20 I=2,NRD
 294          CALL RZIODO(LUN,LREC,IQ(KQSP+LTOP+LD+I),
 295      +               IQ(KQSP+LTOP+(I-1)*LREC+1),1)
 296          IF(IQUEST(1).NE.0)GO TO 30
 297    20 CONTINUE
 298       CALL VBLANK(IQ(KQSP+LTOP+1),4)
 299       CALL UCTOH(CHDIR,IQ(KQSP+LTOP+1),4,NCHD)
 300       CALL ZHTOI(IQ(KQSP+LTOP+1),IQ(KQSP+LTOP+1),4)
 301       CALL SBYT(NCHD,IQ(KQSP+LTOP+KPW1+2),1,5)
 302       CALL UCOPY(IQ(KQSP+LTOP+KPW1),IHPWD,2)
 303       NHPWD=JBYT(IQ(KQSP+LTOP+KPW1+2),6,5)
 304       IQ(KQSP+LTOP+KIRIN)=0
 305       IQ(KQSP+LTOP+KIROUT)=0
 306 #if defined(CERNLIB_NOTNEW)
 307 *
 308 *     Check that the file is not in the NEW format
 309 *
 310       IF (IQ(KQSP+LTOP+KRZVER).NE.0) THEN
 311          CALL ZFATAM
 312      +      (' RZFILE. file cannot be processed by this version of RZ')
 313       ENDIF
 314 #endif
 315
 316       LFREE = 0
 317       LUSED = 0
 318       LRIN  = 0
 319       LPURG = 0
 320       LROUT = 0
 321       LCDIR = LTOP
 322       NLCDIR= 1
 323       NLNDIR= 1
 324       NLPAT = 1
 325       CHCDIR(1)=CHTOP
 326       CHNDIR(1)=CHTOP
 327 *
 328 *             Reset LOCKing word in record 1
 329 *
 330       IF(IOPTD.NE.0)THEN
 331          CALL RZDLOK
 332       ENDIF
 333 *
 334 *             Show locks
 335 *
 336       IF(IOPTL.NE.0)THEN
 337          CALL RZLLOK
 338       ENDIF
 339 #if defined(CERNLIB_QMVAX)
 340 *
 341 *             Set ORGANIZATION type
 342 *
 343       IF(IRELAT.NE.0)THEN
 344          UNLOCK(UNIT=LUN)
 345          CALL SBIT1(IQ(KQSP+LTOP),4)
 346       ENDIF
 347 #endif
 348 *
 349 *            Store default LOG level
 350 *
 351       LOGL = LOGLV + 3
 352       CALL SBYT(LOGL,IQ(KQSP+LTOP),15,3)
 353 *
 354 *     RZ version
 355 *
 356       CALL RZVCYC(LTOP)
 357       IQUEST(13) = IQ(KQSP+LTOP+KRZVER)
 358 *
 359 *     Rebuild bit map?
 360 *
 361       IF(IOPTB.NE.0) CALL RZVERI('//'//CHTOP(1:NCHD),'B')
 362 *
 363 *             UPDATE mode only
 364 *
 365       CALL SBIT1(IQ(KQSP+LTOP),1)
 366       IF(IOPTU.NE.0.OR.IOPT1.NE.0)THEN
 367 *
 368 *            Allocate free records
 369 *
 370          CALL SBIT0(IQ(KQSP+LTOP),1)
 371          CALL MZBOOK(JQPDVS,LFREE,LTOP,-2,'RZFR',0,0,21,2,0)
 372          IQ(KQSP+LFREE-5)=LUN
 373 *
 374 *        IF(IOPTU.EQ.0.AND.IOPT1.EQ.0)THEN
 375          IF(IOPTS.EQ.0)THEN
 376             CALL SBIT1(IQ(KQSP+LTOP),3)
 377             CALL RZLOCK('RZFILE')
 378             IF(IQUEST(1).NE.0)THEN
 379                CALL SBIT1(IQ(KQSP+LTOP),1)
 380                IQ1=IQUEST(1)
 381                CALL MZDROP(JQPDVS,LFREE,' ')
 382                LFREE=0
 383                IQUEST(1)=2+IQ1
 384                GO TO 30
 385             ENDIF
 386          ELSE
 387             CALL SBIT0(IQ(KQSP+LTOP),3)
 388          ENDIF
 389 *
 390 *            Allocate space for used records
 391 *
 392          CALL MZBOOK(JQPDVS,LUSED,LTOP,-3,'RZUS',0,0,21,2,0)
 393          IQ(KQSP+LUSED-5)=LUN
 394       ENDIF
 395       IQUEST(7)=IQ(KQSP+LCDIR+KNKEYS)
 396       IQUEST(8)=IQ(KQSP+LCDIR+KNWKEY)
 397 *
 398    30 RETURN
 399       END