SPL,L,O,M 
!     NAME:   CR..
!     SOURCE: 92067-18205 
!     RELOC:  92067-16185 
!     PGMR:   G.A.A.
! 
!  ***************************************************************
!  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.  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..(8) "92067-16185 REV.2040 800731" 
! 
!  MODIFICATION RECORD: 
! 
!      DATE     REASON
!  1) 780414    TO CLOSE O.BUF AFTER GETTING DEFAULT
!               LU DEFINED (RELEASE THE LOCK). (GLM)
!  2) 780516    TO HANDLE LOCK. ERROR RETURN PARAMETER, AND 
!               TO HANDLE CREA. ERROR RETURN
!  3) 780721    TO USE NEW D.RTR CALLING SEQUENCES
!  4) 790116    TO ZERO SIZE WORDS FOR TYPE 0 CREATE
!  5) 790127    TO ALLOW TYPE 0 FILES ANYWHERE ON ANY CARTRIDGE 
!               IN USER'S ADDRESSING SPACE
!  6) 790226    TO SET EOF CODE (AVOIDING LU LOCK IN OPEN.) 
!  7) 800311    TO DISALLOW CREATE OF TYPE 0 FILE IF LU=DISC
!  8) 800731    TO PROPERLY CLOSE TYPE 0 FILE (SST #4887) 
! 
!     THIS MODULE OF FMGR CREATES EMPTY FILES.
!     IT ALSO CREATES TYPE 0 FILES. 
! 
!     COMMANDS WHICH 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
!         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.,                     \FMGR FILE CREATE ROUTINE
          EXEC,                      \RTE EXEC ROUTINE
          IER.,                      \FMGR ERROR HANDLING ROUTINE 
          NAM..,                     \FMP NAME CHECKING ROUTINE 
          RMPAR                      \PARAMETER FETCH ROUTINE 
             BE SUBROUTINE,EXTERNAL 
! 
      ASSEMBLE ["EXT .MVW"] 
! 
      LET .E.R.,                     \FMGR ERROR WORD 
          D.,                        \ASCII "D.RTR" 
          N.OPL,                     \FMGR SUBPARAMETER ARRAY 
          O.BUF,                     \INTERNAL FMGR BUFFER
          PK.DR,                     \FILE DIRECTORY BUFFER 
          S.CAP                      \9P - SESSION CAPABILITY LEVEL 
             BE INTEGER,EXTERNAL
! 
      LET CR.. BE SUBROUTINE
! 
! 
!     DEFINE 16 WORD TYPE 0 NAME BLOCK
! 
      LET  NAM,NAM1,NAM2(2),LUC,\ 
          EFT,SPLC,RW,SC(8)    BE INTEGER 
! 
!     DEFINE CONSTANTS
! 
      LET  READI    BE CONSTANT (1) 
      LET  WRITI    BE CONSTANT (2) 
      LET  XEQT     BE CONSTANT (1717K) 
      LET  SECT2    BE CONSTANT (1757K) 
      LET  SECT3    BE CONSTANT (1760K) 
      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  STWD     BE CONSTANT (100015K) 
! 
CR..: SUBROUTINE(NO,LIS,ER) GLOBAL
      TY_@N.OPL+2 
      DCB4_[DCB2_[DCB1_[DCB_@O.BUF]+1]+1]+2 
! 
      LIS21_[LIS20_[LIS17_[LIS16_[LIS13_[LIS9_[\
         LIS5_[LIS1_@LIS+1]+4]+4]+4]+3]+1]+3]+1 
! 
      FOR  T_@NAM TO @NAM +15 DO $T_0     !CLEAR TYPE 0 NAME BLOCK
      IF $TY THEN [CREA.(O.BUF, $LIS1,N.OPL)?[\CREA. IF NOT TYPE 0
         ER_-15;RETURN];IER.;RETURN]
      IF $LIS5 >20000K THEN GO TO ILLU    !LU MUST BE NON-ASCII 
      IF $LIS5<1       THEN GO TO ILLU    !NEGATIVE LU ILLEGAL
      IFNOT   $LIS9  THEN  GO TO  MISPM   !RE,WR OR BO MUST BE GIVEN
! 
!     SET R/W CODE IN DIRECTORY ENTRY BUFFER
! 
      IF $LIS9 = RE  THEN RW_100000K
      IF $LIS9 = WR  THEN RW_1
      IF $LIS9 = BO  THEN RW_100001K
      IFNOT RW THEN GO TO ILLPM           !ERROR, NOT RE,WR OR BO 
! 
!     SET SPACING CODE
! 
      IFNOT $LIS13  THEN GO TO  EOFCD     !SKIP IF NO SPACING CODE
      IF $LIS13 = BS   THEN SPLC_100000K
      IF $LIS13 = FS   THEN SPLC_1
      IF $LIS13 = BO   THEN SPLC_100001K
      IFNOT SPLC THEN GOTO ILLPM          !BAD SPACING CODE 
! 
!     SET EOF CODE IN DIRECTORY ENTRY BUFFER (DEFAULT=FMGR DEFAULT) 
! 
EOFCD:IF $LIS17 = EOF THEN EFT_100K 
      IF $LIS17 = PA  THEN EFT_1100K
      IF $LIS17 = LE  THEN EFT_1000K
      IF $LIS16<3 THEN EFT_($LIS17 AND 37K)-<6 !IF NUMERIC,USE AS CTL 
      IF $LIS16 THEN GO TO EOF3 
      CALL EXEC(STWD,$LIS5,EQT5,EQT4,BF)  !STATUS REQUEST ON LU 
      GO TO UNDEF                         !ILLEGAL OR UNDEFINED LU
      EFCOD_1100K                         !ASSUME TTY-PRINTER 
      EQT5_EQT5 AND 37400K                !GET DRIVER TYPE
      IF EQT5 > 13400K THEN [             \IF A DISC (30-33)
        IF EQT5 < 16000K THEN GOTO ILLU]  !THEN ILLEGAL LU
      IF EQT5 > 7000K THEN                \IF DRIVER TYPE > 16
         GO TO EOF1                          !USE EOF CODE OF 100K
      IF EQT5=2400K THEN [                   \IF DVR05 AND
         IF [BF_BF AND 7]=1 THEN GO TO EOF1, \SUBCHANNEL 1 OR 2 
            ELSE [IF BF=2 THEN [             \I.E., CTU EOF 
EOF1:          EFCOD_100K; GO TO EOF2]]]
      IF EQT5=1000K THEN EFCOD_1000K         !IF PUNCH, USE LEADR FN
EOF2: EFT_EFCOD OR ($LIS5 AND 77K)
EOF3: IFNOT EFT THEN GO TO ILLPM
! 
!     SET SUB FUNCTION  (DEFAULT 00=ASCII)
! 
      IFNOT $LIS20 THEN GO TO SETUP       !DEFAULT DATA TYPE TO ASCII 
      IF $LIS20<3 THEN LUC_($LIS21 AND 37K)-<6  !IF NUMERIC, USE IT 
      IF   $LIS21 = BI THEN   LUC_100K
      IF $LIS21=AS THEN GO TO SETUP 
      IFNOT LUC THEN GO TO ILLPM !IF GIVEN AND NOT BI,AS OR NUMERIC 
! 
SETUP: LUC_  LUC+[T_($ LIS5 AND 77K)] 
      EFT_EFT OR T
      NAM.. ($LIS1)                      !CHECK FOR VALID FILE NAME 
      IF  .A. THEN GO TO ILNAM           !ILLEGAL NAME? 
      DIS_$(@N.OPL+1)                    !LU/CRN FROM SUBPARM ARRAY 
      T1_@NAM 
      FOR T_LIS1 TO LIS1+2  DO [$T1_$T;T1_T1+1] !MOVE NAME TO BUFFER
      SC(1)_N.OPL                       !MOVE THE SECURITY CODE 
! 
SCHD: EXEC (23,D.,$XEQT,1,DIS,0,0,NAM,9) !D.RTR TO CREATE DIR ENTRY 
      RMPAR(O.BUF)                       !GET RETURN WORDS TO O.BUF 
      IF O.BUF THEN [ER_O.BUF;RETURN]    !RETURN ON ERROR 
      DISAD_@O.BUF+1                     !DIREC ADDR FROM D.RTR 
      EXEC(23,D.,$XEQT,0,$DISAD,$(DISAD+1),0,0.0,2) !CLOSE FILE 
      RMPAR(O.BUF)
      ER_O.BUF                           !SET ERROR 
      RETURN
! 
ILLU: DO[ ER_ 20 ; RETURN]
MISPM:DO[ ER_ 55 ; RETURN]
ILLPM:DO[ ER_ 56 ; RETURN]
ILNAM:DO[ ER_-15 ; RETURN]
UNDEF:IF S.CAP THEN ER_43, ELSE ER_52        !IF SESSION, ERR 43
      RETURN
! 
      END 
      END 
      END$
                                                                                                                                                                                                                                          