[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / rz / rzmake.F

*
* $Id$
*
* $Log$
* Revision 1.2  1996/04/24 17:27:01  mclareni
* Extend the include file cleanup to dzebra, rz and tq, and also add
* dependencies in some cases.
*
* Revision 1.1.1.1  1996/03/06 10:47:25  mclareni
* Zebra
*
*
#include "zebra/pilot.h"
      SUBROUTINE RZMAKE(LUNIN,CHDIR,NWKEY,CHFORM,CHTAG,NRECP,CHOPT)
*
************************************************************************
*
*           Routine to create a new RZ file
*           To use an already existing file CALL RZFILE
* Input:
*   LUNP    Logical unit number associated with  the RZ file.   A FORTRAN
*           OPEN statement must precede the call to RZFILE.
*           Starting address of the memory area which will contain the RZ
*           information ('M' option)
*   CHDIR   Character variable specifying  the name of the  top directory
*           to be associated with unit LUN.
*   NWKEY   Number of words associated to a key (maximum 5)
*   CHFORM  Character variable describing each element  of the key vector
*           'B' Bit string but not zero
*           'H' Hollerith (4 characters)
*           'I' Integer (nonzero)
*           Ex: CHFORM='IIH' for NWKEY=3 and the 2 first keys are integer
*               and the third one is Hollerith
*   CHTAG   Character array defined as CHARACTER*8 CHTAG(NWKEY).
*           Each  element of  the  array allows  the  description of  the
*           corresponding element in the key vector with a tag of up to 8
*           characters.
*   NRECP   Number of physical records for primary allocation
*   CHOPT   Character variable specifying the selected options.
*           medium
*             default
*                   Disk
*             'M'   Memory
*                   In this  case the user  must have allocated  at least
*                   NRECP*LUNP words of memory starting at address LUN.
*           mode
*             default
*                   Native mode
*             'X'   Exchange mode
*           other
*             'F'   Format NRECP records (unless 'M')
*             'C'   C I/O (unless 'M')
*                   LRECL (words) taken from IQUEST(10)
*             'N'   New format for Cycle information (default is old)
*
* Called by <USER>
*
*  Author  : R.Brun DD/US/PD
*  Written : 01.04.86
*  Last mod: 14.09.93 No longer force exchange mode for LINUX
*          : 09.03.94 S.Banerjee (Change in cycle structure)
*          : 30.01.95 J.Shiers. Permit nrecp>65000 for new format
*
************************************************************************
*
#include "zebra/zunit.inc"
#include "zebra/zstate.inc"
#include "zebra/rzcl.inc"
#include "zebra/rzdir.inc"
#include "zebra/rzclun.inc"
#include "zebra/rzk.inc"
#include "zebra/rzcycle.inc"
#if defined(CERNLIB_QMVAX)
      CHARACTER*16 CHORG
#endif
      CHARACTER    CHOPT*(*),CHDIR*(*),CHFORM*(*)
      CHARACTER*16 CHTOP
      CHARACTER*(*)  CHTAG(*)
      DIMENSION    IOPTV(5),IHDIR(2)
      EQUIVALENCE (IOPTM,IOPTV(1)), (IOPTX,IOPTV(2))
     +,           (IOPTF,IOPTV(3)), (IOPTC,IOPTV(4))
     +,           (IOPTN,IOPTV(5))
*
*-----------------------------------------------------------------------
*
      IQUEST(1)=0
      LOGLV = MIN(NQLOGD,4)
      LOGLV = MAX(LOGLV,-3)
      LUNP  = LUNIN
*
      CALL UOPTC(CHOPT,'MXFCN',IOPTV)
#if !defined(CERNLIB_QCFIO)
      IF(IOPTC.NE.0) THEN
         WRITE(IQPRNT,*) 'RZMAKE. option C ignored - valid only ',
     +      'for MSDOS, Unix and VMS systems'
         IOPTC = 0
      ENDIF
#endif
      IMODEX=IOPTX
      IMODEC=IOPTC
      IF(IOPTC.NE.0) LUNP = IQUEST(11)
#if defined(CERNLIB_FQXISN)
      IMODEX=1
#endif
#if defined(CERNLIB_QMLNX)
C     RZfile maked always with Exchange mode for LINUX
*     IMODEX=1
#endif
      IRELAT=0
*
*                Check NWKEY and NRECP
*
      IF(NWKEY.LE.0.OR.NWKEY.GT.KNMAX)THEN
         IF(LOGLV.GE.-2) WRITE(IQLOG,9010)
 9010    FORMAT(' RZMAKE. NWKEY input value is invalid')
         IQUEST(1) =1
         IQUEST(11)=NWKEY
         GO TO 99
      ENDIF
      IF(NRECP.LT.2.OR.(NRECP.GT.65000.AND.IOPTN.EQ.0))THEN
         IF(LOGLV.GE.-2) WRITE(IQLOG,9011)
 9011    FORMAT(' RZMAKE. NRECP input value is invalid')
         IQUEST(1) =1
         IQUEST(11)=NRECP
         GO TO 99
      ENDIF
*
*          Save existing material (if any)
*
      CALL RZSAVE
*
*            Find record length (as specified in the OPEN statement)
*
*          A, Memory option. LUN contains the buffer address
*                            and the value of LUNP is the block length
*
      IF(IOPTM.NE.0)THEN
         LRECP=LUNP
         IF(LRECP.LT.100.OR.LRECP.GT.10000)LRECP=1024
      ELSE
*
*          B, Standard option DISK. Use information as specified
*             in the Fortran OPEN statement
*
          IF(IOPTC.EQ.0) THEN
#if (!defined(CERNLIB_QMVAX))&&(!defined(CERNLIB_QMVDS))
            INQUIRE(UNIT=LUNP,RECL=LRECB)
#endif
#if defined(CERNLIB_QMVDS)
            LRECB=4096
#endif
#if defined(CERNLIB_QMVAX)
            INQUIRE(UNIT=LUNP,RECL=LRECB,ORGANIZATION=CHORG)
            IF(CHORG.EQ.'RELATIVE')IRELAT=1
#endif
*
#if defined(CERNLIB_RZBYTES)
            LRECP=LRECB/4
#endif
#if !defined(CERNLIB_RZBYTES)
            LRECP=LRECB
#endif
#if defined(CERNLIB_QMCRY)||defined(CERNLIB_QMCV64)
            IF(IOPTX.EQ.0) THEN
               LRECP=LRECB/8
            ELSE
               LRECP=LRECB/4
            ENDIF
#endif
         ELSE
*
*     Take LRECL from IQUEST(10) in case of C I/O option
*
            LRECP = IQUEST(10)
         ENDIF
      ENDIF
*
      LUN = LUNP
      IZRECL = LRECP
      IF(LUN.LE.0.AND.IOPTM.EQ.0)THEN
         IF(LOGLV.GE.-2) WRITE(IQLOG,9012)
 9012    FORMAT(' RZMAKE. LUN input value is invalid')
         IQUEST(1) =1
         IQUEST(11)=LUN
         GO TO 99
      ENDIF
      IF(LRECP.LT.50)THEN
         IF(LOGLV.GE.-2) WRITE(IQLOG,9013)
 9013    FORMAT(' RZMAKE. LRECP input value less than 50')
         IQUEST(1) =1
         IQUEST(11)=LRECP
         GO TO 99
      ENDIF
      IF(LOGLV.GE.0) WRITE(IQLOG,9014) LUNP,LRECP,CHOPT
 9014 FORMAT(' RZMAKE. Unit ',I6,' Initializing with LREC=',I6,
     +', OPT= ',A)
      CALL MZSDIV (0,-7)
*
*           Check if LUN not already defined
*
      LRZ=LQRS
  10  IF(LRZ.NE.0)THEN
         IF(IQ(KQSP+LRZ-5).EQ.LUN)THEN
            IF(LOGLV.GE.-2) WRITE(IQLOG,9015)
 9015       FORMAT(' RZMAKE. Logical unit number already in use')
            IQUEST(1) =1
            IQUEST(11)=LUN
            GO TO 99
         ELSE
            LRZ=LQ(KQSP+LRZ)
            GO TO 10
         ENDIF
      ENDIF
*
*            First call to RZMAKE, create link area
*
      IF(LQRS.EQ.0)THEN
         CALL MZLINK(JQPDVS,'RZCL',LTOP,LTOP,LFROM)
         CALL MZBOOK(JQPDVS,LRZ0,LQRS,1,'RZ0 ',2,2,36,2,0)
         IQ(KQSP+LRZ0-5)=0
         ISAVE = 1
         NHPWD = 0
         CALL VBLANK(IHPWD,2)
      ENDIF
      NCHD  = LEN(CHDIR)
      IF(NCHD.GT.16)NCHD=16
      CHTOP = CHDIR(1:NCHD)
*
*            Create control bank
*
      IDTIME=0
      CALL RZDATE(IDTIME,IDATE,ITIME,2)
      KTAGS = KKDES+(NWKEY-1)/10+1
      NREC  = NRECP
      LREC  = LRECP
      NWREC = (NREC-1)/32 +1
      NW    = 50+NWREC
      NRD   = (NW-1)/LREC +1
      NWL   = NRD*LREC
      LD    = KTAGS+2*NWKEY
      LB    = LD+NRD+1
      LS    = LB+3+NWREC
      LK    = LS
      LF    = LS
*
      CALL MZBOOK (JQPDVS,LTOP,LQRS,1,'RZ  ',10,9,NWL,2,0)
*
*            Disk or memory
*
      IF(IOPTM.EQ.0)THEN
         IQ(KQSP+LTOP-5) = LUN
*
*            C I/O?
         IF(IOPTC.NE.0) CALL SBIT1(IQ(KQSP+LTOP),5)
      ELSE
         NMEM=IQ(KQSP+LRZ0)+1
         IQ(KQSP+LRZ0)=NMEM
         IQ(KQSP+LTOP-5)=-NMEM
         IF(2*NMEM.GT.IQ(KQSP+LRZ0-1))THEN
            CALL MZPUSH(JQPDVS,LRZ0,0,10,'I')
         ENDIF
         IQ(KQSP+LRZ0+2*NMEM-1)=LOCF(LUNP)-LOCF(IQ(1))+1
         IQ(KQSP+LRZ0+2*NMEM  )=LRECP
         LUN=-NMEM
      ENDIF
*
*            Pre-format file
*
      IF((IOPTF.NE.0).AND.(IOPTM.EQ.0))THEN
         DO 100 I=2,NRECP
  100    CALL RZIODO(LUN,LREC,I,IQ(KQSP+LTOP+1),2)
         IF(IQUEST(1).NE.0)THEN
            IF(LOGLV.GE.-1) WRITE(IQLOG,1000) I-1
 1000       FORMAT(' RZMAKE. Could only pre-format',I6,' records')
            IQUEST(1)=0
         ENDIF
      ENDIF
*
*            Write empty record for locks
*
      CALL RZIODO(LUN,LREC,1,IQ(KQSP+LTOP+1),2)
      IF(IQUEST(1).NE.0) GO TO 99
*
*            Build top-directory parameters
*
      CALL SBIT1(IQ(KQSP+LTOP),2)
      CALL VBLANK(IQ(KQSP+LTOP+1),4)
      CALL UCTOH(CHDIR,IQ(KQSP+LTOP+1),4,NCHD)
      CALL ZHTOI(IQ(KQSP+LTOP+1),IQ(KQSP+LTOP+1),4)
#if defined(CERNLIB_QMVAX)
*
*             Set ORGANIZATION type
*
      IF(IRELAT.NE.0)CALL SBIT1(IQ(KQSP+LTOP),4)
#endif
*
      NHPWD = 0
      CALL VBLANK(IHPWD,2)
      CALL UCOPY(IHPWD,IQ(KQSP+LTOP+KPW1),2)
      IQ(KQSP+LTOP+KPW1+2) = NCHD
      IF(IMODEX.GT.0)THEN
         CALL SBIT1(IQ(KQSP+LTOP+KPW1+2),12)
      ENDIF
      IQ(KQSP+LTOP+KDATEC) = IDTIME
      IQ(KQSP+LTOP+KDATEM) = IDTIME
      IQ(KQSP+LTOP+KQUOTA) = NREC
      IQ(KQSP+LTOP+KRUSED) = NRD
      IQ(KQSP+LTOP+KWUSED) = NWL
      IF (IOPTN.NE.0) THEN
        WRITE(IQLOG,7001)
 7001 FORMAT(' RZMAKE. new RZ format selected.',/,
     +       '         This file will not be readable with versions',
     +       ' of RZ prior to release 94B')
        IQ(KQSP+LTOP+KRZVER) = 1
      ELSE
        IQ(KQSP+LTOP+KRZVER) = 0
      ENDIF
      IQ(KQSP+LTOP+KIP1)   = 2
      IQ(KQSP+LTOP+KNFREE) = NWL-LF
      IQ(KQSP+LTOP+KLD)    = LD
      IQ(KQSP+LTOP+KLB)    = LB
      IQ(KQSP+LTOP+KLS)    = LS
      IQ(KQSP+LTOP+KLK)    = LK
      IQ(KQSP+LTOP+KLF)    = LF
      IQ(KQSP+LTOP+KLC)    = NWL+1
      IQ(KQSP+LTOP+KLE)    = NWL
      IQ(KQSP+LTOP+KNWKEY) = NWKEY
      IQ(KQSP+LTOP+LD)     = NRD
      IQ(KQSP+LTOP+LB)     = NWREC
      IQ(KQSP+LTOP+LB+1)   = LREC
      IQ(KQSP+LTOP+LB+2)   = IDTIME
*
      NCHF=LEN(CHFORM)
      NCH =LEN(CHTAG(1))
      IF(NCH.GT.8)NCH=8
      DO 20 I=1,NWKEY
         IF(NCH.LT.8)CALL VBLANK(IHDIR,2)
         CALL UCTOH(CHTAG(I),IHDIR,4,NCH)
         CALL UCOPY(IHDIR,IQ(KQSP+LTOP+KTAGS+2*(I-1)),2)
         IFORM=2
         IF(I.LE.NCHF)THEN
            IF(CHFORM(I:I).EQ.'B')IFORM=1
            IF(CHFORM(I:I).EQ.'H')IFORM=3
            IF(CHFORM(I:I).EQ.'A')IFORM=4
         ENDIF
         IKDES=(I-1)/10
         IKBIT1=3*I-30*IKDES-2
         CALL SBYT(IFORM,IQ(KQSP+LTOP+KKDES+IKDES),IKBIT1,3)
  20  CONTINUE
      CALL ZHTOI(IQ(KQSP+LTOP+KTAGS),IQ(KQSP+LTOP+KTAGS),2*NWKEY)
      DO 30 I=1,NRD
         IQ(KQSP+LTOP+LD+I)=I+1
         CALL SBIT1(IQ(KQSP+LTOP+LB+3),I+1)
  30  CONTINUE
*
*            Store default LOG level
*
      LOGL = LOGLV + 3
      CALL SBYT(LOGL,IQ(KQSP+LTOP),15,3)
      CALL RZVCYC(LTOP)
*
*            Allocate free records
*
      CALL MZBOOK(JQPDVS,LFREE,LTOP,-2,'RZFR',0,0,3,2,0)
      IQ(KQSP+LFREE-5)=LUN
      IQ(KQSP+LFREE+1)=1
      IQ(KQSP+LFREE+2)=NRD+2
      IQ(KQSP+LFREE+3)=NREC
*
*            Allocate space for used records
*
      CALL MZBOOK(JQPDVS,LUSED,LTOP,-3,'RZUS',0,0,21,2,0)
*
      IQ(KQSP+LUSED-5)=LUN
      LRIN  = 0
      LPURG = 0
      LROUT = 0
      LCDIR = LTOP
      NLCDIR= 1
      NLNDIR= 1
      NLPAT = 1
      CHCDIR(1)=CHTOP
      CHNDIR(1)=CHTOP
      IQUEST(1)=0
*
  99  RETURN
      END
Commit	Line	Data
fe4da5cc	1	*
	2	* $Id$
	3	*
	4	* $Log$
	5	* Revision 1.2 1996/04/24 17:27:01 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:25 mclareni
	10	* Zebra
	11	*
	12	*
	13	#include "zebra/pilot.h"
	14	SUBROUTINE RZMAKE(LUNIN,CHDIR,NWKEY,CHFORM,CHTAG,NRECP,CHOPT)
	15	*
	16	************************************************************************
	17	*
	18	* Routine to create a new RZ file
	19	* To use an already existing file CALL RZFILE
	20	* Input:
	21	* LUNP Logical unit number associated with the RZ file. A FORTRAN
	22	* OPEN statement must precede the call to RZFILE.
	23	* Starting address of the memory area which will contain the RZ
	24	* information ('M' option)
	25	* CHDIR Character variable specifying the name of the top directory
	26	* to be associated with unit LUN.
	27	* NWKEY Number of words associated to a key (maximum 5)
	28	* CHFORM Character variable describing each element of the key vector
	29	* 'B' Bit string but not zero
	30	* 'H' Hollerith (4 characters)
	31	* 'I' Integer (nonzero)
	32	* Ex: CHFORM='IIH' for NWKEY=3 and the 2 first keys are integer
	33	* and the third one is Hollerith
	34	* CHTAG Character array defined as CHARACTER*8 CHTAG(NWKEY).
	35	* Each element of the array allows the description of the
	36	* corresponding element in the key vector with a tag of up to 8
	37	* characters.
	38	* NRECP Number of physical records for primary allocation
	39	* CHOPT Character variable specifying the selected options.
	40	* medium
	41	* default
	42	* Disk
	43	* 'M' Memory
	44	* In this case the user must have allocated at least
	45	* NRECP*LUNP words of memory starting at address LUN.
	46	* mode
	47	* default
	48	* Native mode
	49	* 'X' Exchange mode
	50	* other
	51	* 'F' Format NRECP records (unless 'M')
	52	* 'C' C I/O (unless 'M')
	53	* LRECL (words) taken from IQUEST(10)
	54	* 'N' New format for Cycle information (default is old)
	55	*
	56	* Called by <USER>
	57	*
	58	* Author : R.Brun DD/US/PD
	59	* Written : 01.04.86
	60	* Last mod: 14.09.93 No longer force exchange mode for LINUX
	61	* : 09.03.94 S.Banerjee (Change in cycle structure)
	62	* : 30.01.95 J.Shiers. Permit nrecp>65000 for new format
	63	*
	64	************************************************************************
65	*
66	#include "zebra/zunit.inc"
67	#include "zebra/zstate.inc"
68	#include "zebra/rzcl.inc"
69	#include "zebra/rzdir.inc"
70	#include "zebra/rzclun.inc"
71	#include "zebra/rzk.inc"
72	#include "zebra/rzcycle.inc"
73	#if defined(CERNLIB_QMVAX)
74	CHARACTER*16 CHORG
75	#endif
76	CHARACTER CHOPT(),CHDIR(),CHFORM()
77	CHARACTER*16 CHTOP
78	CHARACTER() CHTAG(*)
79	DIMENSION IOPTV(5),IHDIR(2)
80	EQUIVALENCE (IOPTM,IOPTV(1)), (IOPTX,IOPTV(2))
81	+, (IOPTF,IOPTV(3)), (IOPTC,IOPTV(4))
82	+, (IOPTN,IOPTV(5))
83	*
84	*-----------------------------------------------------------------------
85	*
86	IQUEST(1)=0
87	LOGLV = MIN(NQLOGD,4)
88	LOGLV = MAX(LOGLV,-3)
89	LUNP = LUNIN
90	*
91	CALL UOPTC(CHOPT,'MXFCN',IOPTV)
92	#if !defined(CERNLIB_QCFIO)
93	IF(IOPTC.NE.0) THEN
94	WRITE(IQPRNT,*) 'RZMAKE. option C ignored - valid only ',
95	+ 'for MSDOS, Unix and VMS systems'
96	IOPTC = 0
97	ENDIF
98	#endif
99	IMODEX=IOPTX
100	IMODEC=IOPTC
101	IF(IOPTC.NE.0) LUNP = IQUEST(11)
102	#if defined(CERNLIB_FQXISN)
103	IMODEX=1
104	#endif
105	#if defined(CERNLIB_QMLNX)
106	C RZfile maked always with Exchange mode for LINUX
107	* IMODEX=1
108	#endif
109	IRELAT=0
110	*
111	* Check NWKEY and NRECP
112	*
113	IF(NWKEY.LE.0.OR.NWKEY.GT.KNMAX)THEN
114	IF(LOGLV.GE.-2) WRITE(IQLOG,9010)
115	9010 FORMAT(' RZMAKE. NWKEY input value is invalid')
116	IQUEST(1) =1
117	IQUEST(11)=NWKEY
118	GO TO 99
119	ENDIF
120	IF(NRECP.LT.2.OR.(NRECP.GT.65000.AND.IOPTN.EQ.0))THEN
121	IF(LOGLV.GE.-2) WRITE(IQLOG,9011)
122	9011 FORMAT(' RZMAKE. NRECP input value is invalid')
123	IQUEST(1) =1
124	IQUEST(11)=NRECP
125	GO TO 99
126	ENDIF
127	*
128	* Save existing material (if any)
129	*
130	CALL RZSAVE
131	*
132	* Find record length (as specified in the OPEN statement)
133	*
134	* A, Memory option. LUN contains the buffer address
135	* and the value of LUNP is the block length
136	*
137	IF(IOPTM.NE.0)THEN
138	LRECP=LUNP
139	IF(LRECP.LT.100.OR.LRECP.GT.10000)LRECP=1024
140	ELSE
141	*
142	* B, Standard option DISK. Use information as specified
143	* in the Fortran OPEN statement
144	*
145	IF(IOPTC.EQ.0) THEN
146	#if (!defined(CERNLIB_QMVAX))&&(!defined(CERNLIB_QMVDS))
147	INQUIRE(UNIT=LUNP,RECL=LRECB)
148	#endif
149	#if defined(CERNLIB_QMVDS)
150	LRECB=4096
151	#endif
152	#if defined(CERNLIB_QMVAX)
153	INQUIRE(UNIT=LUNP,RECL=LRECB,ORGANIZATION=CHORG)
154	IF(CHORG.EQ.'RELATIVE')IRELAT=1
155	#endif
156	*
157	#if defined(CERNLIB_RZBYTES)
158	LRECP=LRECB/4
159	#endif
160	#if !defined(CERNLIB_RZBYTES)
161	LRECP=LRECB
162	#endif
163	#if defined(CERNLIB_QMCRY)\|\|defined(CERNLIB_QMCV64)
164	IF(IOPTX.EQ.0) THEN
165	LRECP=LRECB/8
166	ELSE
167	LRECP=LRECB/4
168	ENDIF
169	#endif
170	ELSE
171	*
172	* Take LRECL from IQUEST(10) in case of C I/O option
173	*
174	LRECP = IQUEST(10)
175	ENDIF
176	ENDIF
177	*
178	LUN = LUNP
179	IZRECL = LRECP
180	IF(LUN.LE.0.AND.IOPTM.EQ.0)THEN
181	IF(LOGLV.GE.-2) WRITE(IQLOG,9012)
182	9012 FORMAT(' RZMAKE. LUN input value is invalid')
183	IQUEST(1) =1
184	IQUEST(11)=LUN
185	GO TO 99
186	ENDIF
187	IF(LRECP.LT.50)THEN
188	IF(LOGLV.GE.-2) WRITE(IQLOG,9013)
189	9013 FORMAT(' RZMAKE. LRECP input value less than 50')
190	IQUEST(1) =1
191	IQUEST(11)=LRECP
192	GO TO 99
193	ENDIF
194	IF(LOGLV.GE.0) WRITE(IQLOG,9014) LUNP,LRECP,CHOPT
195	9014 FORMAT(' RZMAKE. Unit ',I6,' Initializing with LREC=',I6,
196	+', OPT= ',A)
197	CALL MZSDIV (0,-7)
198	*
199	* Check if LUN not already defined
200	*
201	LRZ=LQRS
202	10 IF(LRZ.NE.0)THEN
203	IF(IQ(KQSP+LRZ-5).EQ.LUN)THEN
204	IF(LOGLV.GE.-2) WRITE(IQLOG,9015)
205	9015 FORMAT(' RZMAKE. Logical unit number already in use')
206	IQUEST(1) =1
207	IQUEST(11)=LUN
208	GO TO 99
209	ELSE
210	LRZ=LQ(KQSP+LRZ)
211	GO TO 10
212	ENDIF
213	ENDIF
214	*
215	* First call to RZMAKE, create link area
216	*
217	IF(LQRS.EQ.0)THEN
218	CALL MZLINK(JQPDVS,'RZCL',LTOP,LTOP,LFROM)
219	CALL MZBOOK(JQPDVS,LRZ0,LQRS,1,'RZ0 ',2,2,36,2,0)
220	IQ(KQSP+LRZ0-5)=0
221	ISAVE = 1
222	NHPWD = 0
223	CALL VBLANK(IHPWD,2)
224	ENDIF
225	NCHD = LEN(CHDIR)
226	IF(NCHD.GT.16)NCHD=16
227	CHTOP = CHDIR(1:NCHD)
228	*
229	* Create control bank
230	*
231	IDTIME=0
232	CALL RZDATE(IDTIME,IDATE,ITIME,2)
233	KTAGS = KKDES+(NWKEY-1)/10+1
234	NREC = NRECP
235	LREC = LRECP
236	NWREC = (NREC-1)/32 +1
237	NW = 50+NWREC
238	NRD = (NW-1)/LREC +1
239	NWL = NRD*LREC
240	LD = KTAGS+2*NWKEY
241	LB = LD+NRD+1
242	LS = LB+3+NWREC
243	LK = LS
244	LF = LS
245	*
246	CALL MZBOOK (JQPDVS,LTOP,LQRS,1,'RZ ',10,9,NWL,2,0)
247	*
248	* Disk or memory
249	*
250	IF(IOPTM.EQ.0)THEN
251	IQ(KQSP+LTOP-5) = LUN
252	*
253	* C I/O?
254	IF(IOPTC.NE.0) CALL SBIT1(IQ(KQSP+LTOP),5)
255	ELSE
256	NMEM=IQ(KQSP+LRZ0)+1
257	IQ(KQSP+LRZ0)=NMEM
258	IQ(KQSP+LTOP-5)=-NMEM
259	IF(2*NMEM.GT.IQ(KQSP+LRZ0-1))THEN
260	CALL MZPUSH(JQPDVS,LRZ0,0,10,'I')
261	ENDIF
262	IQ(KQSP+LRZ0+2*NMEM-1)=LOCF(LUNP)-LOCF(IQ(1))+1
263	IQ(KQSP+LRZ0+2*NMEM )=LRECP
264	LUN=-NMEM
265	ENDIF
266	*
267	* Pre-format file
268	*
269	IF((IOPTF.NE.0).AND.(IOPTM.EQ.0))THEN
270	DO 100 I=2,NRECP
271	100 CALL RZIODO(LUN,LREC,I,IQ(KQSP+LTOP+1),2)
272	IF(IQUEST(1).NE.0)THEN
273	IF(LOGLV.GE.-1) WRITE(IQLOG,1000) I-1
274	1000 FORMAT(' RZMAKE. Could only pre-format',I6,' records')
275	IQUEST(1)=0
276	ENDIF
277	ENDIF
278	*
279	* Write empty record for locks
280	*
281	CALL RZIODO(LUN,LREC,1,IQ(KQSP+LTOP+1),2)
282	IF(IQUEST(1).NE.0) GO TO 99
283	*
284	* Build top-directory parameters
285	*
286	CALL SBIT1(IQ(KQSP+LTOP),2)
287	CALL VBLANK(IQ(KQSP+LTOP+1),4)
288	CALL UCTOH(CHDIR,IQ(KQSP+LTOP+1),4,NCHD)
289	CALL ZHTOI(IQ(KQSP+LTOP+1),IQ(KQSP+LTOP+1),4)
290	#if defined(CERNLIB_QMVAX)
291	*
292	* Set ORGANIZATION type
293	*
294	IF(IRELAT.NE.0)CALL SBIT1(IQ(KQSP+LTOP),4)
295	#endif
296	*
297	NHPWD = 0
298	CALL VBLANK(IHPWD,2)
299	CALL UCOPY(IHPWD,IQ(KQSP+LTOP+KPW1),2)
300	IQ(KQSP+LTOP+KPW1+2) = NCHD
301	IF(IMODEX.GT.0)THEN
302	CALL SBIT1(IQ(KQSP+LTOP+KPW1+2),12)
303	ENDIF
304	IQ(KQSP+LTOP+KDATEC) = IDTIME
305	IQ(KQSP+LTOP+KDATEM) = IDTIME
306	IQ(KQSP+LTOP+KQUOTA) = NREC
307	IQ(KQSP+LTOP+KRUSED) = NRD
308	IQ(KQSP+LTOP+KWUSED) = NWL
309	IF (IOPTN.NE.0) THEN
310	WRITE(IQLOG,7001)
311	7001 FORMAT(' RZMAKE. new RZ format selected.',/,
312	+ ' This file will not be readable with versions',
313	+ ' of RZ prior to release 94B')
314	IQ(KQSP+LTOP+KRZVER) = 1
315	ELSE
316	IQ(KQSP+LTOP+KRZVER) = 0
317	ENDIF
318	IQ(KQSP+LTOP+KIP1) = 2
319	IQ(KQSP+LTOP+KNFREE) = NWL-LF
320	IQ(KQSP+LTOP+KLD) = LD
321	IQ(KQSP+LTOP+KLB) = LB
322	IQ(KQSP+LTOP+KLS) = LS
323	IQ(KQSP+LTOP+KLK) = LK
324	IQ(KQSP+LTOP+KLF) = LF
325	IQ(KQSP+LTOP+KLC) = NWL+1
326	IQ(KQSP+LTOP+KLE) = NWL
327	IQ(KQSP+LTOP+KNWKEY) = NWKEY
328	IQ(KQSP+LTOP+LD) = NRD
329	IQ(KQSP+LTOP+LB) = NWREC
330	IQ(KQSP+LTOP+LB+1) = LREC
331	IQ(KQSP+LTOP+LB+2) = IDTIME
332	*
333	NCHF=LEN(CHFORM)
334	NCH =LEN(CHTAG(1))
335	IF(NCH.GT.8)NCH=8
336	DO 20 I=1,NWKEY
337	IF(NCH.LT.8)CALL VBLANK(IHDIR,2)
338	CALL UCTOH(CHTAG(I),IHDIR,4,NCH)
339	CALL UCOPY(IHDIR,IQ(KQSP+LTOP+KTAGS+2*(I-1)),2)
340	IFORM=2
341	IF(I.LE.NCHF)THEN
342	IF(CHFORM(I:I).EQ.'B')IFORM=1
343	IF(CHFORM(I:I).EQ.'H')IFORM=3
344	IF(CHFORM(I:I).EQ.'A')IFORM=4
345	ENDIF
346	IKDES=(I-1)/10
347	IKBIT1=3I-30IKDES-2
348	CALL SBYT(IFORM,IQ(KQSP+LTOP+KKDES+IKDES),IKBIT1,3)
349	20 CONTINUE
350	CALL ZHTOI(IQ(KQSP+LTOP+KTAGS),IQ(KQSP+LTOP+KTAGS),2*NWKEY)
351	DO 30 I=1,NRD
352	IQ(KQSP+LTOP+LD+I)=I+1
353	CALL SBIT1(IQ(KQSP+LTOP+LB+3),I+1)
354	30 CONTINUE
355	*
356	* Store default LOG level
357	*
358	LOGL = LOGLV + 3
359	CALL SBYT(LOGL,IQ(KQSP+LTOP),15,3)
360	CALL RZVCYC(LTOP)
361	*
362	* Allocate free records
363	*
364	CALL MZBOOK(JQPDVS,LFREE,LTOP,-2,'RZFR',0,0,3,2,0)
365	IQ(KQSP+LFREE-5)=LUN
366	IQ(KQSP+LFREE+1)=1
367	IQ(KQSP+LFREE+2)=NRD+2
368	IQ(KQSP+LFREE+3)=NREC
369	*
370	* Allocate space for used records
371	*
372	CALL MZBOOK(JQPDVS,LUSED,LTOP,-3,'RZUS',0,0,21,2,0)
373	*
374	IQ(KQSP+LUSED-5)=LUN
375	LRIN = 0
376	LPURG = 0
377	LROUT = 0
378	LCDIR = LTOP
379	NLCDIR= 1
380	NLNDIR= 1
381	NLPAT = 1
382	CHCDIR(1)=CHTOP
383	CHNDIR(1)=CHTOP
384	IQUEST(1)=0
385	*
386	99 RETURN
387	END