SPL,L,O,M 
!     NAME:   CR..
!     SOURCE: 92070-18016 
!     RELOC:  92070-16016 
!     PGMR:   G.A.A.           MOD. M.L.K.
! 
!  ***************************************************************
!  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  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) "  92070-1X016  REV.1941  790712"
! 
!     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. 
! 
!  EXTERNAL SUBROUTINES 
      LET CLD.R     BE SUBROUTINE,EXTERNAL,DIRECT 
      LET CLOSE     BE SUBROUTINE,EXTERNAL
      LET CREA.     BE SUBROUTINE,EXTERNAL
      LET D.RIO     BE SUBROUTINE,EXTERNAL
      LET EXEC      BE SUBROUTINE,EXTERNAL
      LET LOCK.     BE SUBROUTINE,EXTERNAL
      LET MSS.      BE SUBROUTINE,EXTERNAL
      LET MVW       BE SUBROUTINE,EXTERNAL
      LET NAM..     BE SUBROUTINE,EXTERNAL
      LET OPEN.     BE SUBROUTINE,EXTERNAL
      LET RWNDF     BE SUBROUTINE,EXTERNAL
      LET WRITF     BE SUBROUTINE,EXTERNAL
!  EXTERNAL VARIBLES
      LET .P1       BE INTEGER,EXTERNAL          !D.RTR CALL PARAMETERS 
      LET .P2       BE INTEGER,EXTERNAL 
      LET .P3       BE INTEGER,EXTERNAL 
      LET .P4       BE INTEGER,EXTERNAL 
      LET .P5       BE INTEGER,EXTERNAL 
      LET .P6       BE INTEGER,EXTERNAL 
      LET .P7       BE INTEGER,EXTERNAL 
      LET .R1       BE INTEGER,EXTERNAL          !D.RTR RETURN PARAMETER
      LET .R2       BE INTEGER,EXTERNAL 
      LET .R3       BE INTEGER,EXTERNAL 
      LET D.SDR     BE INTEGER,EXTERNAL 
      LET O.BUF     BE INTEGER,EXTERNAL 
      LET N.OPL     BE INTEGER,EXTERNAL 
!  INTERNAL SUBROUTINES 
      LET CR..      BE SUBROUTINE 
!  INTERNAL VARIBLES
      LET NAM       BE INTEGER                   !DEFINE TYPE 0 NAME BLOCK
      LET NAM1      BE INTEGER
      LET NAM2      BE INTEGER
      LET LUC       BE INTEGER
      LET EF        BE INTEGER
      LET SP        BE INTEGER
      LET RW        BE INTEGER
      LET SC(8)     BE INTEGER
!  INTERNAL CONSTANTS 
      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 
      LIS21_[LIS20_[LIS17_[LIS16_[LIS13_[LIS9_[  \
             LIS5_[LIS1_@LIS+1]+4]+4]+4]+3]+1]+  \
                  3]+1
! 
!     CREATE FILE FOR TYPES 1 TO 32767
! 
      IF $TY                                     \
           THEN[                                 \
               CREA.(O.BUF,$LIS1,N.OPL)?[ER_ -15];\CHECK FOR ERROR RETURN 
               RETURN]                           !  AND RETURN
! 
!     CREATE TYPE 0 FILES 
! 
      DCB9_ [DCB4_ [DCB_ @O.BUF]+ 4]+ 5 
      ADD_128 
      BLK,RW,SP,EF_ 0                            !INITIALIZE FLAGS
! 
      FOR  T_@NAM TO @NAM+14 DO $T_0             !CLEAR TYPE 0 NAME BLOCK 
! 
      IF $LIS5 >20000K THEN GO TO ILLU           !IF LU IS ASCII, ILLEGAL 
      IF $LIS5<1       THEN GO TO ILLU           !IF LU NEGATIVE, ILLEGAL 
      OPEN.(O.BUF,$LIS5,N.OPL,1)                 !GET DEFAULT EOF 
      CLOSE(O.BUF)                               !NOW CLOSE LU
! 
! 
!     SET   R/W  CODE 
! 
      IFNOT $LIS9    THEN GOTO MISPM             !MISSING PARAMETER 
      IF $LIS9 = RE  THEN RW_100000K             !SET READ CODE 
      IF $LIS9 = WR  THEN RW_1                   !SET WRITE CODE
      IF $LIS9 = BO  THEN RW_100001K             !SET BOTH READ,WRITE CODES 
      IFNOT   RW     THEN  GOTO ILLPM            !IF NO RW CODE, ILLEGAL
! 
!     SET   SPACING CODE
! 
      IFNOT $LIS13  THEN GOTO  EOFCD             !IF NO SP CODE, WORK ON EOF
      IF    $LIS13= BS  THEN   SP_100000K        !SET BACKSPACE CODE
      IF    $LIS13= FS  THEN   SP_1              !SET FORWARD SPACE CODE
      IF    $LIS13= BO  THEN   SP_100001K        !SET BOTH CODES
      IFNOT SP THEN GOTO ILLPM                   !BAD SP CODE 
! 
!     SET  EOF  CODE  (DEFAULT -FMGR DEFAULT) 
! 
EOFCD:IF $LIS17=EOF THEN EF_100K                 !EOF (MAG TAPE)
      IF $LIS17=PA  THEN EF_1100K                !PAGE EJECT
      IF $LIS17=LE  THEN EF_1000K                !PUNCH LEADER
      IF  $LIS16<3  THEN EF_($LIS17 AND 37K)-<6 
      IFNOT  $LIS16 THEN   EF_$DCB4              !GET DEFAULT EOF 
      IFNOT EF THEN GO TO ILLPM                  !ILLEGAL PARAMETER 
! 
!     SET   SUB FUNCTION  (DEFAULT 00=ASCII)
! 
      IFNOT $LIS20  THEN GOTO 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
! 
      IFNOT [LULK_ $(@N.OPL+1)] THEN[            \USE DISC INDICATED
         D.RIO(READI);                           \GET COPY OF MASTER DIR. 
         IFNOT [LULK_-D.SDR]  THEN[              \IF NOTHING MOUNTED
              ER_ -32;                           \ SET ERROR -32
              RETURN]]                           ! 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
      .P6,.P7_ 0                                 !SET TYPE AND SIZE TO 0
      CLD.R                                      !CALL D.RTR FOR A DIR ENT
      IF [ER_.R1] THEN GOTO EXIT                 !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 
! 
      DSLU_ (.R2 AND 77K) + 7700K                !CREATE DISC LU W/PROTECT
      EXEC(READI,DSLU,O.BUF,128,TR,SECT)         !READ THE BLOCK
      IF $B # 128  THEN[                         \
             IF [T_LULK] < 0 THEN T_ -T;         \
             MSS.(2001,T+2000);                  \
             GOTO EXIT]                          !
! 
      OFFSET_@O.BUF+OFFSET+4                     !SET ADDRESS OF LU WORD
      MVW(@LUC, OFFSET,12)
      EXEC(WRITI,DSLU,O.BUF,128,TR,SECT)         !WRITE NEW BLOCK 
! 
EXIT: LOCK.(LULK,5)                              !UNLOCK THE DISC 
      O.BUF_0                                    !CLEAR FIRST WORD FOR CLOSE
      RETURN
! 
ILLU: DO[ ER_ 20 ; RETURN]                       !ILLEGAL LU
MISPM:DO[ ER_ 55 ; RETURN]                       !MISSING PARAMETER 
ILLPM:DO[ ER_ 56 ; RETURN]                       !ILLEGAL PARAMETER 
ILNAM:DO[ ER_-15 ; RETURN]                       !ILLEGAL NAME
! 
      END 
      END 
      END$
                                                                                      