ASMB,R,L,C
*     NAME:   CRETS 
*     SOURCE: 92070-18041 
*     RELOC:  92070-16041 
*     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  92070-1X041  REV.1941  790709
* 
      HED CRETS 
      ENT CRETS 
      EXT .ENTR,GTOPN,ECREA 
      EXT CLD.R,.P1,.P2,.P3,.P4,.R1 
      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
* 
* 
*  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-WORD ARRAY.  WORD 1 IS THE SIZE IN 
*              124-WORD DOUBLE SECTORS.  WORD 2 IS USED 
*              ONLY FOR TYPE 2 FILES AND IS THE RECORD LENGTH.
*              THE DEFAULT SIZE IS 30 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)
* 
*  JSIZ        (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
* 
      JSB GTOPN     GET CURRENT OPEN FLAG 
      DEF *+1 
      STA OPFLG     SAVE IT FOR LATER 
      AND B377      ISOLATE THE ID 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 OPFLG      AND RESTORE OPEN FLAG
      AND B3400     ISOLATE THE CPU#
      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 OPFLG 
* 
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 LDA .9        SET UP D.RTR CALLING PARAMETERS 
      STA .P1       FOR SCRATCH FILE PURGE ON OPEN
      LDA LU,I
      STA .P2       SET UP LU 
      LDA NAME,I    GET FIRST TWO CHARACTERS
      STA .P3       STORE IN D.RTR CALLING PARAMETER
      DLD NAME2,I   GET LAST FOUR CHARACTERS OF NAME
      IOR SIGN      SET SCRATCH FILE PURGE BIT
      DST .P4       STORE IN .P4 AND .P5
      JSB CLD.R     CALL D.RTR
* 
      LDA .R1       GET ERROR PARAMETER 
      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 
* 
.9    DEC 9 
.10   DEC 10
B60   OCT 60
B377  OCT 377 
B3400 OCT 3400
M38   DEC -38 
M100  DEC -100
M101  DEC -101
M2    DEC -2
M10   DEC -10 
SIGN  OCT 100000
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 
* 
*     VARIBLES
* 
NAME2 NOP 
NAME3 NOP 
OPFLG NOP 
DUMSZ BSS 2         DUMMY RETURN SIZE 
* 
END   EQU * 
      END 
                                                                                                                                                                