ASMB,R,L,C,Q
*     NAME:   CRETS 
*     SOURCE: 92067-18502 
*     RELOC:  92067-16125 
*     PGMR:   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.       *
*  ***************************************************************
* 
* 
      NAM CRETS,7 92067-16125 REV.1940 790726 
* 
      HED CRETS 
      ENT CRETS 
      EXT .ENTR, EXEC, D.R, OVRD. 
      EXT $$CPU, ECREA, RMPAR 
      SUP 
* 
* 
*  CRETS     IS THE SCRATCH FILE CREATION MODULE OF THE REAL TIME 
*            FILE MANAGEMENT PACKAGE. 
* 
*            THE FORTRAN CALLING SEQUENCE IS: 
* 
*     CALL CRETS(IDCB,IERR,NUM,NAME,ISIZE,ITYPE,IS,ILU,IBLK,JSIZ) 
*        O R
*     IER = CRETS(IDCB,IERR,NUM,NAME,ISIZE,ITYPE,IS,ILU,IBLK,JSIZ)
* 
*        W H E R E: 
* 
*     IDCB     IS THE ADDRESS OF A 144-WORD ARRAY WHICH 
*              CRETS WILL USE AS A SCRATCH AREA.  IF
*              ISIZE<0 THEN THE CREATED FILE IS ALSO
*              OPENED TO THIS DATA CONTROL BLOCK. 
* 
*     IERR     IS THE ADDRESS TO WHICH THE ERROR CODE 
*              IS RETURNED.  THIS INFORMATION IS ALSO 
*              RETURNED IN THE A REGISTER.
* 
*              ERROR CODES ARE: 
* 
*     >0   THE CRETS WAS SUCCESSFUL - THE #SECTORS IS RETURNED
*     -1   THE DISC IS DOWN 
*     -2   DUPLICATE NAME 
*     -4   FILE TOO LONG
*     -6   CARTRIDGE NOT FOUND
*     -10  NOT ENOUGH PARAMETERS IN THE CALL
*     -13  DISC LOCKED
*     -14  DIRECTORY FULL 
*     -15  ILLEGAL NAME 
*     -16  ILLEGAL TYPE OR SIZE 
*     -38  ILLEGAL FILE NUMBER
* 
* 
*  NUM         THE SCRATCH FILE NUMBER TO CREATE    0 THROUGH 99
* 
* 
*  NAME        IS A 3-WORD ARRAY CONTAINING THE NEW FILE'S NAME 
*              WHICH CRETS HAS CREATED. NOTE: THIS IS A RETURNED
*              PARAMETER. 
* 
*  ISIZE       A TWO-ENTRY ARRAY.  EACH ENTRY IS A DOUBLE WORD. 
*              THE FIRST ENTRY IS THE FILE SIZE IN 128-WORD 
*              DOUBLE SECTORS  (DOUBLE WORD).  THE SECOND ENTRY 
*              IS USED ONLY FOR TYPE 2 FILES AND IS THE RECORD
*              LENGTH  (DOUBLE WORD).  THE DEFAULT FILE SIZE IS 
*              24 BLOCKS. 
* 
*  ITYPE       IS THE FILE TYPE--MUST BE >0.  THE DEFAULT IS TYPE 3.
* 
*  IS          (OPTIONAL); IS THE FILE'S SECURITY CODE. 
*              IF IS>0 THE FILE IS WRITE PROTECTED. 
*              IF IS<0 THE FILE IS OPEN PROTECTED.
*              IF IS=0 OR IS NOT CODED THE FILE IS PUBLIC.
* 
*  ILU         (OPTIONAL); DIRECTS THE CRETS TO:
*               IF ILU<0 THEN THE DISC AT LOGICAL UNIT (-ILU).
*               IF ILU>0 THEN THE DISC WITH LABEL ILU.
*               IF ILU=0 OR NOT CODED, THE FIRST AVAILABLE
*                 DISC WITH ENOUGH ROOM IS USED.
* 
*  IBLK        (OPTIONAL); SPECIFIES A DCB BUFFER AREA OF 
*              IBLK WORDS.  (NORMALLY 128 IS USED.)  MUST BE A
*              MULTIPLE OF 128.  THE BUFFER MUST BE AN EVEN 
*              DIVISOR OF THE FILE SIZE SO ONLY PART OF 
*              THE SPECIFIED SIZE MAY BE USED.  THE USED SIZE IS: 
*              USED SIZE=FILE SIZE/N  WHERE 
*              N=(FILE SIZE/IBLK)+(IF REMAINDER THEN 1,ELSE 0)
* 
*  JSIZE       (OPTIONAL)  THE SIZE OF THE FILE CREATED IF
*              SUCCESSFUL.  THIS IS A DOUBLE WORD VALUE 
* 
      SKP 
CRETS NOP           ENTRY POINT 
      LDA CRETS     MOVE THE
      STA DRETS       RETURN ADDRESS
      LDA DZERO     GET DUMMY 0 FOR DEFAULT 
      STA NAME
      STA SC
      STA LU
      STA IBLK
      LDA DFLTS     GET DEFAULT SIZE
      STA SIZE         (=24 BLOCKS) 
      LDA DFLTT     GET DEFAULT TYPE
      STA TYPE         (= 3)
      LDA DDMSZ     GET POINTER TO DUMMY SIZE 
      STA FSIZ      STORE AT PARAMETER ADDRESS
      JMP DRETS+1   GO SET UP PARAMETERS
      SPC 3 
DCB   NOP 
IERR  NOP 
NUM   NOP 
NAME  NOP 
SIZE  NOP 
TYPE  NOP 
SC    NOP 
LU    NOP 
IBLK  NOP 
FSIZ  NOP 
* 
DRETS NOP 
      JSB .ENTR 
      DEF DCB 
* 
      LDA NAME      TEST FOR ENOUGH 
      CPA DZERO       PARAMETERS
      JMP ER10      NOT ENOUGH!  ERROR
      LDA NAME      GET POINTER TO USER'S NAME BUFFER 
      INA           INCREMENT TO SECOND WORD
      STA NAME2     AND SAVE
      INA           INCREMENT TO THIRD WORD 
      STA NAME3     AND SAVE
* 
      CLA           CALCULATE WHAT THE ID SEGMENT NUMBER
      STA IDNUM      IS FOR THIS PROGRAM.  STEP 
      LDB KEYWD       THROUGH THE KEYWORD TABLE UNTIL 
KEY   ISZ IDNUM      AN ADDRESS IS FOUND THAT MATCHES 
      XLA B,I       XEQT - THE CURRENT PROGRAM EXECUTING. 
      CPA XEQT      MATCH?
      JMP CONVT     FOUND IT SO GO CONTINUE 
      INB           STEP POINTER IN KEYWORD TABLE 
      JMP KEY        AND GO TRY THE NEXT ONE
* 
CONVT LDA IDNUM     GET ID SEGMENT NUMBER 
      JSB CHAR      CONVERT TO ASCII
      STB NAME2,I   STORE TEMPORARILY IN LOW BITS 
      JSB CHAR      CONVERT THE NEXT CHAR OF ID # 
      STB NAME,I    STORE IN LOW BITS 
      JSB CHAR      CONVERT 100'S DIGIT 
      BLF,BLF       SHIFT TO HIGH BYTE
      ADB NAME,I    ADD 10'S DIGIT
      STB NAME,I    AND STORE IN USER'S BUFFER
* 
      LDB NAME2,I   GET 1'S DIGIT 
      LDA $$CPU     GET CPU FLAG
      ALF,ALF        AND PUT IN UPPER BYTE
      LSL 8         SHIFT BYTES INTO POSITION IN B
      ADB B60       ADD 60B TO CONVERT TO ASCII 
      STB NAME2,I   STORE IN USER'S BUFFER
* 
      LDA NUM,I     TEST SCRATCH FILE NUMBER
      SSA           TEST IF NEGATIVE
      JMP ER38        YES, ERROR 38 
      ADA M100      TEST FOR TOO LARGE
      SSA,RSS 
      JMP ER38        YES, ERROR 38 
* 
      LDA NUM,I     GET NUMBER AGAIN
      JSB CHAR      CONVERT 1'S TO ASCII
      STB NAME3,I   STORE IN USER'S BUFFER
      JSB CHAR      CONVERT UPPER CHARACTER 
      BLF,BLF       SHIFT UP
      ADB NAME3,I   ADD LOWER CHARACTER 
      STB NAME3,I   AND STORE IN USER'S BUFFER
* 
*     CALL ECREA
* 
CREAT JSB ECREA     CALL DOUBLE WORD CREATE 
      DEF RTN 
      DEF DCB,I 
      DEF IERR,I
      DEF NAME,I
      DEF SIZE,I
      DEF TYPE,I
      DEF SC,I
      DEF LU,I
      DEF IBLK,I
      DEF FSIZ,I
DZERO DEF ZERO
      DEF ILNAM 
* 
RTN   SZA,RSS       TEST FOR ERROR
      JMP EXIT      NO ERROR, EXIT
      CPA M2        A -2 ERROR? 
      JMP PURGE     YES, DO SCRATCH FILE PURGE
EXIT  STA IERR,I    NO, EXIT WITH CREAT ERROR CODE
      JMP DRETS,I 
* 
* 
* 
PURGE CCE           SET UP D.RTR CALLING PARAMETERS 
      LDA XEQT      PUT ID SEGMENT ADDRESS WITH 
      RAL,ERA        BIT 15 SET 
      STA IDNUM       INTO 1ST PARAMETER
* 
      DLD NAME,I    SET UP NAME WITH
      CCE            SCRATCH FILE PURGE BIT 
      RBL,ERB         SET AND PASS IT TO
      DST PARAM        D.RTR IN A STRING
      LDA NAME3,I   PUT 3RD WORD INTO 
      STA PARAM+2    STRING ALSO
* 
      JSB EXEC      SCHEDULE D.RTR TO DO OPEN WITH
      DEF SCRTN      SCRATCH FILE PURGE FLAG SET
      DEF .23 
      DEF D.R 
      DEF IDNUM 
      DEF OVRD. 
      DEF LU,I
      DEF SC,I
      DEF ZERO
      DEF PARAM     STRING
      DEF .3        3 WORDS LONG
* 
SCRTN JSB RMPAR 
      DEF *+2 
      DEF PARAM 
* 
      LDA PARAM 
      CPA M101      IS IT -101 ?
      JMP EXIT      YES, ERROR, CAN'T PURGE 
      JMP CREAT     NO, GO TRY TO CREATE THE FILE AGAIN 
* 
* 
ER38  LDA M38       SET ILLEGAL FILE NUMBER RETURN
      JMP EXIT
* 
ER10  LDA M10       SET NOT ENOUGH PARAMETERS 
      JMP EXIT
* 
*     CHARACTER CONVERSION SUBROUTINE 
* 
CHAR  NOP 
      CLB           CLEAR UPPER BITS
      DIV .10       CONVERT TO DECIMAL CHARACTER
      ADB B60       CONVERT TO ASCII
      JMP CHAR,I    RETURN
      SKP 
* 
*     CONSTANTS 
* 
.3    DEC 3 
.10   DEC 10
.23   DEC 23
B60   OCT 60
M38   DEC -38 
M100  DEC -100
M101  DEC -101
M2    DEC -2
M10   DEC -10 
ZERO  NOP 
      NOP           TWO NECESSARY FOR DOUBLE WORD 
DFLTS DEF DSIZE 
DSIZE NOP           DEFAULT SIZE
      DEC 24          = 24 BLOCKS 
DFLTT DEF DTYPE 
DTYPE DEC 3           = 3 
DDMSZ DEF DUMSZ 
ILNAM OCT 70707 
XEQT  EQU 1717B 
KEYWD EQU 1657B 
A     EQU 0 
B     EQU 1 
* 
*     VARIBLES
* 
IDNUM NOP   
NAME2 NOP   
NAME3 NOP   
* 
PARAM BSS 5         FOR D.RTR AND RMPAR 
* 
DUMSZ BSS 2         DUMMY RETURN SIZE 
* 
END   EQU * 
      END 
                      