SPL,L,O,M,C 
!     NAME:   CR..  
!     SOURCE: 92064-18157 
!     RELOC:  92064-16055 
!     PGMR:   G.A.A.
!     MOD:    G.L.M.
! 
!  ***************************************************************
!  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1977.  ALL RIGHTS     *
!  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
!  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
!  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
!  ***************************************************************
! 
! 
      NAME CR..(7) " 92064-16055  REV.1650  761021" 
! 
!     THIS  MODULE  OF  THE  RTE  FMP 
!     ROUTINE F M G R         CREATES EMPTY 
!     FILES,  IT ALSO         CREATS TYPE 
!     ZERO    FILES.
!     COMMANDS   THIS ROUTINE HANDLES 
!     ARE:
!     CR,NAMR 
!         WHERE 
!         NAMR IS  A  NAME REFERENCE
!           WHICH INCLUDES
!          SC     SECURITY    CODE
!           CR    CARTRIDGE   ID
!          TY     TYPE
!           SZ 1  SIZE  (NO. OF BLOCKS) 
!           SZ 2   RECORD SIZE (ONLY IF TY=2) 
!     OR
!     CR,NAMR,LU,RWOP,SPOP,EOFOP,  SUBFUN OP
!         WHERE : 
!         NAMR IS AS ABOVE EXCEPT 
!         TY=0
!           (IN THIS CASE CR IS FORCED TO-2)
!         LU    IS THE DEVICE  LOGICAL UNIT 
!         RWOP  IS  THE  READ  WRITE  OPTION
!             I.E. "READ", "WRITE", "BOTH"
!         SPOP  IS THE  SPACING  OPTION 
!              I.E. " BSPACF", "FSPACE", "BOTH" 
!         EOF  IS THE END OF FILE OPTION
!              I.E.  "EOF","LEADER","PAGE", 
!                  NUMERIC SUB FUNCTION.
!         SUBFUNOP IS THE READ/WRITE
!                    SUB FUNCTION 
!               (I.E. "BINARY","ASCII",NUMERIC
!                    SUBFUNCTION. 
!     DEFINE   EXTERNALS
! 
      LET CREA.,NAM..,EXEC, \ 
           RWNDF,WRITF, IER.,\
      OPEN.,LOCK.,D.RIO,MVW,RMPAR,MSS.\ 
                BE SUBROUTINE,EXTERNAL
! 
      LET CLD.R BE SUBROUTINE,EXTERNAL,DIRECT 
      LET FM.AB BE LABEL,EXTERNAL 
! 
! 
      LET N.OPL,IDCB1,.E.R,.P1,.P2,.P3,.P4,.P5,\
          D.SDR                   BE INTEGER,EXTERNAL 
!      DEFINE   LOCAL   SUBS. 
! 
      LET         CR..  BE  SUBROUTINE
! 
!     DEFINE   TYPE ZERO NAME BLOCK 
! 
      LET  NAM,NAM1,NAM2,LUC,\
           EF,SP  ,RW,SC(8)    BE INTEGER 
! 
!     DEFINE   CONSTANTS
! 
      LET  XEQT     BE CONSTANT (1717K) 
      LET  EOF      BE CONSTANT (42517K)
      LET  LE       BE CONSTANT (46105K)
      LET  PA       BE CONSTANT (50101K)
      LET  AS       BE CONSTANT (40523K)
      LET  BI       BE CONSTANT (41111K)
      LET  RE       BE CONSTANT (51105K)
      LET  WR       BE CONSTANT (53522K)
      LET  BO       BE CONSTANT (41117K)
      LET  BS       BE CONSTANT (41123K)
      LET  FS       BE CONSTANT (43123K)
! 
      LET READI     BE CONSTANT (1) 
      LET WRITI     BE CONSTANT (2) 
      LET A         BE CONSTANT (0) 
      LET B         BE CONSTANT (1) 
! 
CR..: SUBROUTINE(NO,LIS, ER) GLOBAL 
      TY_@N.OPL+2 
! 
      DCB9_[DCB4_[R3_[R2_[DCB_@IDCB1]+1]+1]+2]+5
! 
      LIS21_[LIS20_[LIS17_[LIS16_[LIS13_[LIS9_[\
             LIS5_[LIS1_@LIS+1]+4]+4]+4]+3]+1]+\
                  3]+1
! 
      ADD_128 
      BLK,RW,SP,     EF_0  !INITILIZE FLAGES
! 
      FOR  T_@NAM TO @NAM+14 DO $T_0   !CLEAR TYPE 0 NAME BLOCK 
      IF $TY THEN [CREA.(IDCB1, $LIS1,N.OPL)?[\ 
                     ER_-15];RETURN]
! 
! 
      IF $LIS5 >20000K THEN GO TO ILLU
      IF $LIS5<1       THEN GO TO ILLU
      OPEN. (IDCB1,$LIS5,N.OPL,20000K)!SET DEFAULT EOF
                                      !AND INHIBIT LEADER IF PUNCH
! 
      $DCB9_0           !ALSO PREVENT TRAILER ON CLOSE
      IFNOT   $LIS9  THEN  GO TO  MISPM 
!     SET   R/W  CODE 
      IF $LIS9 = RE  THEN   RW_100000K
      IF $LIS9 = WR THEN RW_1 
      IF $LIS9 = BO  THEN RW_100001K
      IFNOT   RW    THEN  GO TO ILLPM 
!     SET   SPACING CODE
      IFNOT $LIS13  THEN GO TO  EOFCD 
      IF   $LIS13= BS  THEN   SP_100000K
      IF $LIS13 = FS  THEN  SP_1
      IF  $LIS13=BO THEN SP_100001K 
      IFNOT SP THEN GOTO ILLPM !BAD SP COMMAND
!     SET  EOF  CODE  (DEFAULT -FMGR DEFAULT) 
! 
EOFCD:IF $LIS17=EOF THEN EF_100K
      IF   $LIS17=PA   THEN   EF_1100K
      IF $LIS17=LE THEN EF_1000K
      IF  $LIS16<3  THEN EF_($LIS17 AND 37K)-<6 
      IFNOT  $LIS16  THEN   EF_$DCB4
      IFNOT EF THEN GO TO ILLPM 
! 
!     SET   SUB FUNCTION  (DEFAULT 00=ASCII 
! 
      IFNOT $LIS20  THEN GO TO SETUP
      IF   $LIS20<3 THEN   LUC_($LIS21 AND 37K)-<6
      IF   $LIS21 = BI THEN   LUC_100K
      IF $LIS21=AS THEN GO TO SETUP 
      IFNOT LUC THEN GO TO ILLPM !IF GIVEN AND NOT SET ERROR
! 
SETUP: LUC_  LUC+[T_($ LIS5 AND 77K)] 
      EF_EF OR T
       SC(1)_N.OPL                     !SET SECURITY CODE 
      NAM.. ($LIS1) 
      AREG_$0 
      IF  AREG  THEN GO TO ILNAM
! 
! 
! 
      D.RIO(READI)                     !GET CURRENT COPY OF MASTER DIRECTORY
      IFNOT [LULK_-D.SDR] THEN \       !IF NOTHING MOUNTED
              [ER_-6;RETURN]           !GIVE ERROR AND EXIT 
! 
! 
      LOCK.(LULK,3)?[RETURN]  ! LOCK THE DISC 
! 
! 
! 
      .P1_1                            !SET FUNCTION CODE 
      .P2_LULK                         !SET THE NEG DISK LU 
      .P3_$LIS1                        !SET 1ST 2 CHAR OF NAME
      .P4_$(LIS1+1)                    !NEXT TWO
      .P5_$(LIS1+2)                    !LAST TWO
! 
      ASSEMBLE "CLA          SET TYPE=0"
      ASSEMBLE "CLB          SET SIZE=0"
! 
! 
! 
      CLD.R                            !CALL D.RFP TO ASSIGN A DIR ENT
! 
      RMPAR(IDCB1)                     !FETCH RETURN PARMS
      IF [ER_IDCB1] THEN RETURN        !EXIT IF ERROR 
      TR_(($R2 AND 177700K) -> 6)        !ISOLATE TRACK 
      SECT_ $R3 AND 377K                !   SECTOR AND
      OFFSET_ (($R3 AND 177400K)->8)    !OFFSET OF DIR ENTRY
! 
! 
      EXEC(READI,D.SDR,IDCB1,128,TR,SECT) !READ THE BLOCK 
      IF $B # 128 THEN [MSS.(1, D.SDR);GOTO FM.AB]
! 
! 
! 
      OFFSET_@IDCB1+OFFSET+4           !SET ADDRESS OF LU WORD
      MVW(@LUC, OFFSET,12)
      EXEC(WRITI,D.SDR,IDCB1,128,TR,SECT) !WRITE NEW BLOCK
! 
! 
      LOCK.(LULK,5) 
      IDCB1_0                          !CLEAR FIRST WORD FOR CLOSE
      RETURN
! 
ILLU: DO[ ER_ 20 ; RETURN]
MISPM:DO[ ER_ 55 ; RETURN]
ILLPM:DO[ ER_ 56 ; RETURN]
ILNAM:DO[ ER_-15 ; RETURN]
! 
      END 
      END 
      END$
                                                                                                          