ASMB,R,L,C
*     NAME:   CREAT 
*     SOURCE: 92070-18040 
*     RELOC:  92070-16040 
*     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.       *
*  ***************************************************************
* 
* 
      NAM CREAT,7  92070-1X040  REV.1941  790709
* 
      HED CREAT 
      ENT CREAT,ECREA 
      EXT CLOSE,$OPEN,.ENTR,GTOPN 
      EXT CLD.R,.P1,.P2,.P3,.P4,.P6,.P7,.P8,.P9 
      EXT NAM..,$DBLX,.R1,.R2,.R3,.R5 
      SUP 
* 
* 
*  CREAT     IS THE FILE CREATION MODULE OF THE REAL TIME 
*            FILE MANAGEMENT PACKAGE. 
* 
*            THE FORTRAN CALLING SEQUENCE IS: 
* 
*     CALL CREAT(IDCB,IERR,NAME,ISIZE,ITYPE,IS,ILU,IBLK,JSIZ) 
*        O R
*     IER = CREAT(IDCB,IERR,NAME,ISIZE,ITYPE,IS,ILU,IBLK,JSIZ)
* 
*        W H E R E: 
* 
*     IDCB     IS THE ADDRESS OF A 144-WORD ARRAY WHICH 
*              CREAT 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 CREAT 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 
* 
* 
* 
*  NAME        IS A 3-WORD ARRAY CONTAINING THE NEW FILE'S NAME.
*              THE NAME MUST CONTAIN ONLY LEGAL ASCII 
*              CHARACTERS INCLUDING EMBEDDED BLANKS. COMMAS,
*              + SIGN, - SIGN ARE NOT ALLOWED.
*              IN ADDITION THE FIRST
*              CHARACTER MUST BE NON-NUMERIC AND NON-BLANK. 
* 
*  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.
* 
*  ITYPE       IS THE FILE TYPE--MUST BE >0.
* 
*  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 CREAT 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, FOR ECREA ONLY) FOR A SUCCESSFUL FILE 
*              CREATION, THE FILE SIZE IS RETURNED IN THE DOUBLE
*              WORD AT JSIZ.
* 
*    SCHEDULE PARAMETERS FOR D.RTR
* 
*   P1. FUNCTION CODE (1) 
*   P2. +CR\-LU 
*   P3. NAME 1,2
*   P4.      3,4
*   P5.      5,6
*   P6. TYPE
*   P7. FILE SIZE 
*   P8. RECORD SIZE 
*   P9. SEC CODE
* 
      SKP 
ECREA NOP           DOUBLE WORD ENTRY 
      CCA           SET DOUBLE WORD FLAG
      LDB ECREA     SET UP RETURN ADDRESS 
      JMP SETUP     GO FINISH 
      SPC 5 
CREAT NOP 
      CLA           SET FALSE FOR DBL FLAG
      LDB CREAT     GET RETURN ADDRESS
SETUP STA DBLWD     STORE DOUBLE FLAG 
      STB DREAT     STORE RETURN ADDRESS
      LDA DZERO 
      STA SC
      STA LU
      STA TYPE
      STA IBLK
      STA SCFLG 
      LDA DDMSZ 
      STA FSIZ
      JMP DREAT+1 
      SPC 5 
DCB   NOP 
IERR  NOP 
NAME  NOP 
SIZE  NOP 
TYPE  DEF ZERO
SC    DEF ZERO
LU    DEF ZERO
IBLK  DEF ZERO
FSIZ  NOP 
      NOP 
SCFLG DEF ZERO      SCRATCH FILE CREATE FLAG
      SPC 1 
DREAT NOP           ENTRY POINT 
      JSB .ENTR     TRANSFER THE PARAMETERS 
      DEF DCB 
      LDA TYPE      MAKE SURE THERE ARE 
      CPA DZERO     ENOUGH
      JMP ER10      NO - ERROR EXIT 
* 
      LDA DBLWD     GET DBL FLAG
      SZA,RSS       DOUBLE OR SINGLE? 
      JMP SINGL     SINGLE, SKIP TESTS
      DLD SIZE,I    DID USER PASS -1 ?
      ADA B         ADD A AND B TO CHECK FOR -1 PASSED
      CPA N2        RESULT EQUAL TO -2? 
      JMP STBZ      YES, JUST STORE THEN
      DLD SIZE,I    NO, GET SIZE AGAIN TO 
      JSB $DBLX     CHECK RANGE 
      JMP EXIT      ERROR (A = ERROR CODE)
STBZ  STB DSIZE     SAVE LO ORDER BITS
      LDA TYPE,I    IS THIS TYPE
      CPA .2         TYPE 2 ? 
      RSS           YES, MUST CHECK SIZE
      JMP UPDAT     NO
      ISZ SIZE      POINT TO SECOND 
      ISZ SIZE      DOUBLE WORD OF PAIR 
      DLD SIZE,I    NOW GET SIZE
      JSB $DBLX     CHECK RANGE 
      JMP EXIT      ERROR RETURN
      STB DSIZ2     SAVE SIZE 
UPDAT LDA ADSIZ     POINT TO INTERNAL 
      STA SIZE      SIZE ARRAY
* 
SINGL JSB CLOSE     GO CLOSE THE DCB (IF OPEN)
      DEF *+2 
      DEF DCB,I 
      SZA           NO ERROR
      CPA N11       AND NOT OPEN ERROR - OK 
      RSS           SO SKIP IF THIS IS THE CASE 
      JMP EXIT      ELSE EXIT  SOME CLOSE ERROR 
* 
* 
* 
      JSB GTOPN     GET CURRENT OPEN FLAG 
      DEF *+1 
      CPA SCFLG,I   IS THE SCRATCH FLAG SET AND CORRECT?
      JMP SETNM     YES, THEN SKIP NAME CHECK 
      JSB NAM..     GO CHECK THE NAME 
      DEF *+2 
      DEF NAME,I
      SZA           IF OK SKIP
      JMP EXIT      ELSE EXIT ERROR 
* 
SETNM LDA NAME,I    GOOD NAME SO
      STA .P3        SET
      ISZ NAME        UP
      DLD NAME,I       SKELETON DIRECTORY 
      DST .P4           ENTRY IN BUF
      LDA TYPE,I
      SZA           TYPE MUST BE
      SSA           >0
      JMP ER16      NOT >0 ; ERR
      STA .P6 
      LDB SIZE,I    GET THE SIZE
      SZB,RSS       IF SIZE IS ZERO,
      JMP ER16        THEN ERROR
      SSB,RSS       IF POSITIVE 
      JMP POSTV       GO CHECK SIZE 
      CCB           NEGATIVE, SET SIZE TO -1 FOR D.RTR
      JMP STRP7     GO STORE .P7
POSTV RBL           DOUBLE SIZE TO PHYSICAL SECTORS 
      SSB           REQUEST > 32K 
      JMP ER16      YES, ERROR
STRP7 STB .P7       SET 
      ISZ SIZE      STEP TO RECORD SIZE 
      CPA .2        IF NOT TYPE TWO 
      CLA,RSS       THEN
      JMP CREA4     SKIP SIZE TEST
      LSR 10        SHIFT TO A FOR DIVIDE 
      DIV SIZE,I    IF OVER FLOW THE RECORD SIZE TO SMALL 
      SOC           IF OK SKIP
      JMP ER4       ELSE ERROR FILE TOO LARGE 
CREA4 LDA SIZE,I
      LDB .P6       GET TYPE
      CPB .1        IF TYPE=1 
      LDA .128       SET SIZE TO 128
      CPB .2        IF TYPE TWO SIZE MUST BE GIVEN
      SSA,RSS       SIZE GIVEN? 
      RSS           YES; OR NOT TYPE TWO  SKIP
      JMP ER4       ELSE ERROR
      ADB N3        TYPE 3 OR GREATER 
      SSB,RSS       YES, THEN 
      CLA           CLEAR RECORD SIZE 
      STA .P8       SET RECORD SIZE 
      LDA SC,I      SET 
      STA .P9        SECURITY CODE
      CLA,INA       SET 
      STA .P1       FUNCTION CODE 
      LDA LU,I      SET 
      STA .P2          THE LU/CR WORD 
      JSB CLD.R     GO CALL D.RTR 
* 
      LDA .R1       GET D.RTR COMPLETION
      SSA            CODE - OK
      JMP EXIT      NO; TAKE EXIT 
      LDA .R2        YES; SET UP
      STA DCB,I     TO CALL 
      LDB DCB        $OPEN
      CLE,INB         TO
      LDA .R3          OPEN 
      STA B,I           THE 
      LDA DCB            FILE 
      LDB SC,I
      STO           SET UP FOR A UPDATE OPEN
      JSB $OPEN     SET UP REST OF DCB
      DEF IBLK,I    ADDRESS OF BLOCK SIZE 
      DEF .R5       ADDRESS OF NO OF SECTORS/TRACK
      JMP EXIT      DISC ERROR - EXIT 
      LDA TYPE,I    GET TYPE
      ADA N3        IF 3 OR MORE
      SSA           SKIP TO WRITE EOF 
      JMP EXIT0     NOT RANDOM ACCESS FILE
      LDA FLAGS     SET WRITTEN ON FLAG IN DCB
      LDB DCB       GET WRITE FLAG
      ADB .13       ADDRESS 
      STA B,I       SET WRITTEN ON FLAG 
      ADB .3        STEP TO THE BUFFER
      CCA           AND SET EOF 
      STA B,I       IN FIRST WORD OF BUFFER 
EXIT0 LDA .R1       NO; USE D.RTR RETURN FOR ERROR
EXIT  STA IERR,I    SET SINGLE WORD ERROR CODE
      ISZ DBLWD     TEST DBL FLAG 
      JMP DREAT,I   SINGLE WORD EXIT
      SSA           ERROR?
      JMP DREAT,I   YES, RETURN 
      CLB           SET B FOR NORMAL COMPLETION (HI BITS 0) 
      SWP           PUT HI BITS IN A, LO IN B 
      DST FSIZ,I    STORE FILE SIZE 
      STA IERR,I    STORE 0 IN ERROR CODE 
      JMP DREAT,I   DOUBLE WORD EXIT
      SPC 3 
ER4   LDA N4        SET ERROR 
      JMP EXIT       CODE 
ER10  LDA N10         AND 
      JMP EXIT         EXIT 
ER16  LDA N16       GET THE ERROR CODE
      JMP EXIT      TAKE EXIT 
      SKP 
N16   DEC -16 
N10   DEC -10 
N11   DEC -11 
N2    DEC -2
N3    OCT -3
N4    OCT -4
.1    OCT 1 
.2    DEC 2 
.3    OCT 3 
.13   DEC 13
.128  DEC 128 
FLAGS OCT 100001    IB AND WR FLAGS 
ZERO  NOP           \ THESE TWO ARE DUMMY ZERO FOR
      NOP           / FOR DOUBLE WORD 
DZERO DEF ZERO
DSIZE NOP           \ DUMMY SIZE IS 
DSIZ2 NOP           /  TWO WORDS
ADSIZ DEF DSIZE     ADDRESS TO INTERNAL SIZE PARAMETER
DBLWD NOP           DOUBLE WORD FLAG
DDMSZ DEF DUMSZ     ADDRESS OF DUMMY SIZE 
DUMSZ BSS 2         DUMMY RETURN SIZE FOR ECREA 
* 
A     EQU 0 
B     EQU 1 
      SPC 1 
END   EQU * 
      SPC 1 
      END 
                                            