ASMB,R,L,C
*     NAME:   CREAT 
*     SOURCE: 92064-18179 
*     RELOC:  92064-16058 
*     PGMR:   G.A.A.
*     MOD:    G.L.M 
* 
*  ***************************************************************
*  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1977.  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  92064-16058  REV.1650  761024
* 
      HED CREAT 
      ENT CREAT 
      EXT CLOSE,$OPEN,.ENTR 
      EXT $LIBR,$LIBX,CLD.R,.P1,.P2,.P3,.P4,.P5 
      EXT NAM..,RMPAR 
      EXT EXEC
      EXT D.R 
      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)
*        O R
*     IER = CREAT(IDCB,IERR,NAME,ISIZE,ITYPE,IS,ILU,IBLK) 
* 
*        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)
* 
* 
*    SCHEDULE PARAMETERS FOR D.RFP
* 
*   P1. FUNCTION CODE (1) 
*   P2. +CR\-LU 
*   P3. NAME 1,2
*   P4.      3,4
*   P5.      5,6
*   (A) TYPE
*   (B) FILE SIZE 
*   W27 RECORD SIZE 
*   W28 SEC CODE
* 
      SKP 
CREAT NOP 
      LDA DZERO 
      STA SC
      STA LU
      STA TYPE
      STA IBLK
      LDA CREAT 
      STA DREAT 
      JMP DREAT+1 
* 
DCB   NOP 
IERR  NOP 
NAME  NOP 
SIZE  NOP 
TYPE  DEF ZERO
SC    DEF ZERO
LU    DEF ZERO
IBLK  DEF ZERO
      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 
      JSB CLOSE     GO CLOSE THE DCR (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 NAM..     GO CHECK THE NAME 
      DEF *+2 
      DEF NAME,I
      SZA           IF OK SKIP
      JMP EXIT      ELSE EXIT ERROR 
      SPC 2 
      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
      BLS           DOUBLE TO GET 64-WORD SECTORS 
      SSB           MUST BE >0 OR 
      CCB           SET TO -1 
      SZB,RSS       IF ZERO 
      JMP ER16      ERROR 
      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
CREA3 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 
* 
*    SAVE WDS 27 AND 28 OF IDSEG
*    THEN PASS PARMS 8&9 IN THEIR SPOT
* 
*     UPON RETURN FROM D.RFP RESTORE ORIGIONAL CONTENTS 
* 
* 
      LDA XEQT      FETCH IDSEG ADDRESS 
      ADA .26       ADVANCE TO ADDRESS OF WD27
      STA T27       SAVE IT 
      DLD A,I       FETCH 27&28 
      DST WD27      SAVE EM 
      DLD .P8       FETCH PARMS 8&9 
      JSB ST267     SET THEM INTO IDSEG 
      DLD .P6       SET A&B=PARMS 6&7 
      JSB CLD.R     GO CALL D.RFP 
* 
* 
      SPC 2 
      SPC 2 
      JSB RMPAR     YES;
      DEF *+2        CALL RMPAR 
      DEF .P1         TO GET RETURN CODES 
* 
*  RESET 27&28
* 
      DLD WD27
      JSB ST267 
* 
      LDA .P1       GET D.RTR COMPLETION
      SSA            CODE - OK
      JMP EXIT      NO; TAKE EXIT 
      LDA .P2        YES; SET UP
      STA DCB,I     TO CALL 
      LDB DCB        $OPEN
      CLE,INB         TO
      LDA .P3          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 .P5       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
      CCA           SET WRITTEN ON AND EOF FLAG IN DCB
      LDB DCB       GET WRITE FLAG
      ADB .13       ADDRESS 
      STA B,I       SET WRITTEN ON FLAG 
      ADB .3        STEP TO THE BUFFER  AND SET EOF 
      STA B,I       IN FIRST WORD OF BUFFER 
EXIT0 LDA .P1       NO; USE D.RTR RETURN FOR ERROR
EXIT  STA IERR,I    SET ERROR CODE
      JMP DREAT,I   AND EXIT
      SPC 3 
ER4   LDA N4        SET ERROR 
      JMP EXIT       CODE 
ER10  LDA N10         AND 
      JMP EXIT         EXIT 
      SPC 3 
ER16  LDA N16       GET THE ERROR CODE
      JMP EXIT      TAKE EXIT 
      SPC 3 
TMP   NOP 
N16   DEC -16 
N10   DEC -10 
N11   DEC -11 
N3    OCT -3
N4    OCT -4
.1    OCT 1 
.2    DEC 2 
.3    OCT 3 
.4    DEC 4 
.9    DEC 9 
.5    DEC 5 
.13   DEC 13
.128  DEC 128 
DLU   NOP 
TRACK NOP 
ZERO  NOP 
DZERO DEF ZERO
.P6   NOP 
.P7   NOP 
.P8   NOP 
.P9   NOP 
T27   NOP 
WD27  BSS 2 
.26   DEC 26
* 
* 
ST267 NOP 
      JSB $LIBR 
      NOP 
      DST T27,I 
      JSB $LIBX 
      DEF ST267 
* 
* 
      SPC 3 
A     EQU 0 
B     EQU 1 
XEQT  EQU 1717B 
      SPC 1 
END   EQU * 
      SPC 1 
      END 
                                                                                                                                                                                                                          