* USE ASMB,R,L,N FOR THE M1 VERSION\ ASMB,R,L,Z FOR M2&M3 
* 
* 
      HED RTE-M DIRECTORY MANAGER PROGRAM/SUBROUTINE(FLPY)
* 
* 
*    Z OPTION FOR M2/M3 VERSION 
*    N OPTION FOR M1 VERSION
* 
* 
* 
*********************** 
*    M2/M3 VERSION    * 
*********************** 
* 
*     NAME:   D.RFP 
*     SOURCE: 92064-18170 
*     RELOC:  92064-16056 
*     PGMR:   G.A.A.
*     MOD:    G.L.M 
* 
* 
* 
************************
*    M1  VERSION       *
************************
* 
*     NAME:    $D.RF
*     SOURCE:  92064-18170
*     RELOC:   92064-16060
*     PRMGR:   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.       *
*  ***************************************************************
* 
* 
* 
      IFZ 
* 
**************************************
*       BEGIN M2\3 VERSION CODE      *
**************************************
* 
* 
      NAM D.RFP,2,1  92064-16056  REV.1650  761020
      EXT PRTN,RMPAR,P.PAS,PMOVE
* 
      XIF 
* 
**************************************
*       END M2\3 VERSION CODE        *
**************************************
* 
* 
* 
      IFN 
* 
**************************************
*       BEGIN M1 VERSION CODE        *
**************************************
* 
* 
      NAM D.RFP,6  92064-16060 REV.1650  761020 
      EXT .ENTP 
      ENT $D.RF 
* 
      XIF 
* 
**************************************
*       END M1 VERSION CODE          *
**************************************
* 
* 
      EXT EXEC,$CDIR
      EXT $LIBR,$LIBX 
* 
* 
      SUP 
*            RTE FMP DIRECTORY ROUTINE    NOV/72**GAA 
* 
* THIS PROGRAM IS THE CENTRAL MANAGER OF THE RTE FILE MANAGEMENT
* SYSTEM. IT OWNS THE DIRECTORY AND PERFORMS ALL WRITES 
* ON IT.
* 
* PROGRAM WISHING TO ACCESS THE DIRECTORY 
* SCHEDULE (WITH WAIT) THIS PROGRAM.
* 
* CALLS ARE AS FOLLOWS (P1,P2,P3,P4,P5 ARE THE PASSED PARAMETERS):
* 
* 
* 1. OPEN 
*     P1. FUNCTION CODE =11 
*     P2. -LU,+CR,0 
*     P3. E,NAME(1,2) E(BIT 15) INDICATES EXCLUSIVE OPEN IF SET 
*     P4. 0,NAME(3,4) S(BIT 15) INDICATES SCRATCH FILE PURGE. 
*     P5. 0,NAME(5,6) 
* 
* 2. CLOSE
*     P1. FUNCTION CODE =0
*     P2. TR,LU 
*     P3. OFFSET,SECTOR  /DIRECTORY ADDRESS 
*     P4. 0,-(NO. SECTORS TO BE DELETED),+ PURGE EXTENTS ONLY 
*     P5. 
* 
* 3. CREAT
*     P1. FUNCTION CODE =1
*     P2. -LU,+CARTRIDGE,0    SEE 1.P5. 
*     P3. NAME (1,2)
*     P4. NAME (3,4)
*     P5. NAME (5,6)
*     P6. TYPE       \  TYPE=0
*     P7. FILE SIZE  \  0 
*     P8. REC SIZE   \  NOT PASSED
*     P9. SEC CODE   \  NOT PASSED
* 
* 4. CHANGE NAME
*     P1. FUNCTION CODE=2 
*     P2. TR,LU         (FROM DCB WD 1)   
*     P3. OFFSET,SECTOR (FROM DCB WD 2 OF FILE BEING RENAMED) 
*     P4. NEW NAMME(1)                                            
*     P5. NEW NAMME(2)                                            
*     P6. NEW NAMME(3)                                            
*     P7. NOT USED
*     P8. LU OF FILE
*     P9. NOT USED
* 
* 6. SET,CLEAR LOCK ON DISC 
*     P1. FUNCTION = 3 FOR SET, 5 FOR CLEAR 
*     P2. -LU,+CARTRIDGE  (0 NOT LEGAL)  DISC TO BE LOCKED
*     P3. 
*     P4. 
*     P5. 
* 
* 7. MOUNT,DISMOUNT,UPDATE CALL 
*     P1. FUNCTION =7 
*     P2. -LU,+CR 
*     P3. LU
*     P4. LAST TRACK
*     P5. DISKETTE REFERENCE
*     P6. LOCK WORD 
*     P7. SUBFUNCTION CODE: -1=UPDATE DRN ONLY
*                            0=DISMOUNT CALL
*                           -2=MOUNT CALL 
* 
* 8. EXTENSION OPEN 
*     P1. FUNCTION CODE= 6(READ), 8(WRITE)
*     P2. TR,LU        \
*     P3. OFFSET,SECTOR \DIRECTORY ADDRESS OF MASTER ENTRY
*     P4. EXTENSION NUMBER
*     P5. 
* 
      SKP 
* 
* WORD FORMATS FOR DOUBLE DUTY WORDS
* 
*  15...6 5..0       15...8 7...0 
*  TRACK ^ LU        OFFSET^SECTOR
*                   #SEC/TR^SECTOR
* 
* RETURN PARAMETERS 
*     R1. ERROR CODE    IF >0 THEN #SEC IN FILE  (0=> TYPE 0) 
*     R2. TR,LU        \
*     R3. OFFSET,SECTOR \ DIRECTORY ADDRESS - OPEN & CREATE CALLS 
*     R4. TR(LU IF TYPE 0)/ FILE ADDRESS ON OPEN & CREATE CALLS 
*     R5. #SEC/TR,SECTOR /
* 
* ERROR CODES 
*     0 OR POSITIVE -NO ERROR 
*    -1              DISC DOWN
*    -2              DUPLICATE NAME 
*    -3              FILE NOT FOUND 
*    -5              READ EXTENT OPEN AND EXTENT NOT FOUND
*    -6              CARTRIDGE NOT FOUND
*    -8              FILE IS CURRENTLY OPEN (ALSO FOR REJECT LOCK)
*    -9              FILE CURRENTLY OPEN TO THE SAME PROGRAM
*    -11             FILE NOT OPEN (CLOSE)
*    -13             DISC LOCKED
*    -14             DIRECTORY FULL 
* 
*    -100            BOOTUP AND LU 2 DOES NOT REFERENCE INITIALIZED 
*                    FMGR DISK
*    -101            ILLEGAL PARAMETERS IN CALL 
*    -102            ILLEGAL CALL SEQUENCE (LOCK NOT REQUESTED FIRST) 
      SKP 
*     SPC 1 
* 
* 
BUF   BSS 128 
INIT  EQU BUF 
* 
      ORG BUF       PUT INITIALIZE CODE IN BUFFER AREA
*    FETCH DIRECT ADDRESSES FOR DIRECTORIES 
      STB XTMPB     SAVE B
      JSB .ADDR 
      DEF $CDIR 
      STA CRDIR 
      ADA N1        BACK UP TO END OF DIRECTORY WORD
      STA MDSTP     SET MASTER DIRECTORY STOP WORD
* 
* 
* 
* 
* 
*     NOTE! 
*     BOOT UP ON LU2 WILL NOT WORK IF LU2 IS ASSIGNED TO
*     THE FIXED HEAD DISK. THIS IS BECAUSE THE DRIVER 
*     (DVR30) WILL NOT RETURN LAST TRACK INFORMATION. 
* 
* 
* 
      LDA $CDIR     FETCH FIRST WORD OF CARTRIDGE DIRECTORY 
      CMA,SSA,INA     IF ZERO OR POSITIVE 
      JMP BGCLR         THEN CONTINUE 
* 
      STA TLU       SAVE THE LU 
      CCA           SET 
      STA XXX         FIRST FLAG
* 
* 
XREAL JSB EXEC
      DEF XRTN
      DEF X.1       READ
      DEF TLU 
      DEF XTBUF 
      DEF X.16
      DEF XTRK
      DEF XZRO      SECTOR ZERO 
* 
XRTN  JMP BAD 
* 
      ISZ XXX       IF FIRST--SKIP
      JMP XOTIT     GO CHECK DIR ID 
* 
      ADB XN1 
      STB XTRK      SET LAST TRACK
      JMP XREAL     GO GET DIR ID 
* 
* 
XOTIT LDA XTBUF     FETCH FIRST WORD OF ID
      CPB X.16      MUST HAVE 16 WORDS
      SSA,RSS       AND FIRST WORD MUST BE NEGATIVE 
       JMP BAD      NO GOOD--EXIT 
* 
      LDA HD3       FETCH LABEL 
      SSA           MUST BE POSITIVE
       JMP BAD
* 
      STA TDRN      SAVE IT 
      LDA HD4       FETCH FIRST TRK 
      CMA 
      ADA HD7 
      SSA           MUST BE LESS THAN FIRST DIR TRK 
       JMP BAD
* 
      LDA HD8       FETCH #DIR TRKS 
      SSA,RSS       MUST BE NEGATIVE
       JMP BAD
* 
* 
      LDA DTLU
      LDB CRDIR 
      JSB PMOVE 
X.4   OCT 4 
* 
BGCLR CLA 
      STA BEGI2 
      LDB XTMPB     RESTORE B 
      JMP BG2 
* 
XTMPB NOP 
* 
* 
BAD   LDA X.BIG     RESET LAST TRACK AS DEC 2000
      STA XTRK
      LDA X.100 
      JMP CREX
* 
* 
XXX   NOP 
XN1   OCT -1
X.1   OCT 100001    DON'T ABORT 
X.16  DEC 16
X.100 DEC -100
X.BIG DEC 2000
* 
* 
TLU   NOP 
XTRK  DEC 2000
TDRN  NOP 
XZRO  NOP 
* 
* 
DTLU  DEF TLU 
XTBUF NOP 
      NOP 
      NOP 
HD3   NOP 
HD4   NOP 
      NOP 
      NOP 
HD7   NOP 
HD8   NOP 
      BSS 8 
* 
* 
.ADDR NOP 
      LDA .ADDR 
      LDA A,I 
      RAL,CLE,SLA,ERA 
      JMP *-2 
      ISZ .ADDR 
      JMP .ADDR,I 
* 
* 
* 
* 
      IFN 
* 
**************************************
*       BEGIN M1 VERSION CODE        *
**************************************
* 
BEGIN HLT 37B       FORCE ERROR IF LOADED AS SUB IN USER AREA.
* 
**************************************
*       END M1 VERSION CODE          *
**************************************
* 
* 
      XIF 
      ORR           :CONTINUE 
* 
CRDIR DEF $CDIR     ADDRESS OF CART DIR 
* 
******************************************
* 
.20   DEC 20
B777  OCT 777 
N1    OCT -1
.9    DEC 9 
ID    NOP 
* 
      IFZ 
* 
**************************************
*       BEGIN M2\3 VERSION CODE      *
**************************************
* 
* 
P1    NOP            ID 
P2    NOP            FUNCTION 
P3    NOP            CR\-LU\0 
P4    NOP 
P5    NOP 
*--------------------FROM SCHED REQUEST-------------
P6    NOP            FROM CALLERS ID SEG:  XA 
      NOP 
      NOP            THESE POSITION THE CALL PARMS FOR CREATE 
P7    NOP                                  XB 
P8    NOP                                  W27
P9    NOP                                  W28
* 
      XIF 
* 
* 
**************************************
*       END M2\3 VERSION CODE        *
**************************************
* 
* 
      IFN 
* 
**************************************
*       BEGIN M1 VERSION CODE        *
**************************************
* 
* 
.26   DEC 26
* 
TDB NOP 
      DEC 14
      NOP 
P1    NOP 
P2    NOP 
P3    NOP 
P4    NOP 
P5    NOP 
P6    NOP 
..P7  NOP 
      NOP 
P7    NOP 
P8    NOP 
P9    NOP 
* 
* 
*      NOTE:  THIS ROUTINE (M1 VERSION) WILL RUN ONLY IN M1.
*             DO NOT ATTEMPT TO USE IT IN M2 OR M3 AS IT IS 
*             NOT A TRUE RE-ENTRANT ROUTINE (IT DEPENDS ON THE
*             METHOD OF HANDLING RE-ENTRANT ROUTINES WHICH ONLY 
*             M1 SUPORTS) 
* 
$D.RF NOP           ENTRY POINT 
      JSB $LIBR     RE-ENTRANT
      DEF TDB          ENTRY
      JSB .ENTP 
P1A   DEF P1        FETCH CALL PARMS
      STA TDB+2     SET RETURN ADDRESS
* 
      LDA P1        FETCH ADDRESS OF CALL PARMS 
      LDB P1A       FETCH LOCAL BUF ADDRESS 
      JSB PMOVE     GO GET EM 
      OCT 7         ALL 7 OF THEM 
* 
      LDA ..P7
      STA P7        SET UP FOR INTERNAL STRUCTURE 
* 
* 
* 
BEGI2 JMP INIT      GO DO BOOT-UP THING 
BG2   LDA XEQT      FETCH ID SEGMENT ADDRESS
      STA ID        SAVE IT FOR INTERNAL USE
      ADA .26       ADVANCE TO WORD 27
* 
      XIF 
* 
**************************************
*       END M1 VERSION CODE          *
**************************************
* 
* 
* 
* 
* 
* 
      SPC 2 
      IFZ 
* 
**************************************
*       BEGIN M2\3 VERSION CODE      *
**************************************
* 
* 
BEGIN JSB RMPAR     FETCH 
      DEF *+2         CALL
      DEF P1             PARMS
* 
BEGI2 JMP INIT      GO DO BOOT-UP THING 
BG2   LDA XEQT      FETCH ID SEG ADDR 
      ADA .20       ADVANCE TO FATHER INFO. 
      LDA A,I           AND FETCH IT
      RAL           POSITION FATHER WAIT BIT TO SIGN
      SSA,RSS       CONTINUE ONLY IF FATHER IS WAITING
      JMP EXIT2     NOT WAITING--ERROR EXIT 
* 
      RAR           REPOSITION ID SEG # OF FATHER 
      AND B777      ISOLATE IT
      ADA N1
      ADA KEYWD     ADD TO TABLE OF ID SEGS 
      LDA A,I       FETCH ID SEG ADDRESS OF CALLER
      STA ID
* 
      ADA .9        ADVANCE TO XA 
      LDB A,I       AND FETCH IT
      STB P6          NOW SAVE
      INA           ADVANCE TO XB 
      LDB A,I         FETCH IT
      STB P7             AND SAVE 
      ADA .16       ADVANCE TO WORD 27
      XIF 
* 
**************************************
*       END M2\3 VERSION CODE        *
**************************************
* 
* 
* 
      DLD A,I       FETCH WDS 27&28 
      DST P8        SAVE FOR PARMS P8 AND P9
      SPC 2 
      SPC 2 
      CLB 
      STB FIRST     CLEAR THE FIRST FLAG
      STB TMP1
* 
* FETCH ADDRESS OF CARTRIDGE DIRECTORY. 
* 
      LDA CRDIR     SET LOCK SEARCH FOR FIRST 
      STA DIRAD     ENTRY 
      SKP 
*     THE LOCK ROUTINE SEARCHES THE DISC DIRECTORY FOR THE
*     REFERENCED DISC.
* 
*     FOR THE FIRST CALL DIRAD SHOULD POINT AT THE
*     FIRST WORD IN $CDIR.  SUBSEQUENTLY LOCK 
*     WILL UPDATE DIRAD EACH CALL.
* 
*     WITH THE EXCEPTION OF THE DISC DIRECTORY UPDATE THE DISC
*     MUST BE FOUND.  IN THIS CASE, EXIT IS TO THE CREAT ROUTINE
* 
*     ON EXIT ATRAK CONTAINS THE DIRECTORY TRACK
*              ALU     CONTAINS THE DIRECTORY LU
*              A       CONTAINS THE LOCK WORD 
* 
*     ON SUBSEQUENT CALLS IF THE DISC ID WAS 0, THE NEXT
*     DISC IS RETURNED.  IF THE DISC ID WAS NOT 0,
*     A NOT FOUND EXIT IS TAKEN.
* 
NEXT  LDA P2        FETCH LU
      LDB P1        FETCH FUNCTION
      CCE,SLB,RSS    IS FUNCTION EVEN?
      JMP LOCK3     YES; GO EXTRACT LU
      CMA,CCE,SSA,INA E_0 INDICATES CARTRIDGE LABEL 
      CMA,CLE,INA     E_1 INDICATES LU(SET +) 
      LDB TMP1      GET PREVIOUS ID 
      STA TMP1      STORE ID
      CME,SZB       IF NOT A  ZERO, ID ON SECOND
      JMP EX6       CALL TAKE -6 EXIT 
      SPC 1 
      RAL,ERA       SET SIGN BIT IF A LABEL SEARCH
      STA TMP2      AND SET FOR COMPARE 
      SPC 1 
LOCK6 LDA TMP2      SET THE FOUND BIT IN E IF 
      CMA,CLE,INA   A ZERO ID 
      LDB DIRAD     GET CURRENT DIRECTORY ADD.
LOCK2 CPB MDSTP,I   END OF DIRECTORY? 
      JMP LOCK5     YEP--GO CHECK FOR TYPE 7 CALL 
      LDA B,I       GET FIRST WORD
      SZA,RSS       IF 0 THEN END 
      JMP LOCK5     SO GO CHECK FOR  DIRECTORY
      STA ALU       UPDATE; ELSE SAVE LU
      CPA TMP2      IS THIS THE REQUIRED DISC?
      CCE           YES  SET E TO 1 TO INDICATE FOUND 
      INB           STEP TO TRACK ADDRESS AND 
      LDA B,I       SET 
      STA ATRAK     IN ATRAK
      INB           STEP TO 
      LDA B,I       LABEL AND FETCH 
      IOR SIGN      SET SIGN FOR COMPARE
      SEZ,INB,RSS   STEP TO LOCK ADDRESS SKIP IF FOUND
      CPA TMP2      IS THIS THE REQUESTED DISC? 
      JMP LOCK4     YES; GO EXIT
      INB           NO; STEP TO NEXT ONE
      JMP LOCK2     AND GO CHECK IT 
      SPC 2 
*                   LU AND TRACK IN (A) 
* 
LOCK3 AND B77       MASK TO LU
      STA TMP2      SAVE LU 
      STA B         SAVE LU IN B FOR TEST 
      XOR P2        MASK TO TRACK 
      ALF,RAL       ROTATE TO 
      RAL,ALF       LOW A AND 
      STA DITR      SAVE THE TRACK
      CPB RDPS      DO WE HAVE THIS ONE ALREADY?
      JMP DECOD     YES  SO GO DECODE THE REQUEST 
      JMP LOCK6     NO  SO GO LOOK FOR IT 
      SPC 2 
LOCK4 STB DIRAD     FOUND - UPDATE CURRENT
      ISZ DIRAD     ADDRESS FOR NEXT TIME 
      LDA B,I       LOCK TO A 
      SZA           IF NOT LOCKED 
      CPA ID        OR LOCKED TO CALLER 
      JMP DECOD     SKIP
      LDA TMP1      ELSE IF 
      SZA,RSS       MULTI-DISC SEARCH 
      JMP NEXT      CONTINUE
      JMP EX13      ELSE EXIT LOCKED DISC 
      SPC 2 
DECOD LDA P1        FETCH FUNCTION CODE 
      SSA           CHECK REQUEST CODE
      JMP EX101     NEGATIVE - EXIT 
      ADA N12 
      SSA,RSS 
      JMP EX101     GREATER THAN 11- EXIT 
      ADA TABAD     INDEX INTO THE FUNCTION 
      JMP A,I       GO EXECUTE THE FUNCTION 
      SPC 2 
N12   DEC -12 
      SPC 2 
TABAD DEF TABA+12 
TABA  JMP CLOSE     0 
      JMP CREAT     1 
      JMP CNAM      2 
      JMP RLOCK     3 
      JMP EX101     4 
      JMP ULOCK     5 
      JMP EXOPN     6 
      JMP MDUDT     7 
      JMP EXOPN     8 
      JMP EX101     9 
      JMP EX101   10
      JMP OPEN     11       USE 9 FOR OPEN
      SPC 5 
* 
*  RDPS     CURRENT DISK FLAG 
* 
RDPS  NOP 
      SPC 5 
* 
*  WCSR     WRITE CURRENT BLOCK 
* 
WCSR  NOP 
      LDA WCS       GET WRITE FLAG
      ISZ RW        SET REQUEST CODE TO WRITE 
      SZA           IF NOT WRITTEN ON SKIP
      JSB RWSUB     ELSE WRITE THE BLOCK
      CLA,INA       RESET REQUEST CODE TO 
      STA RW        READ
      JMP WCSR,I    AND EXIT (A=1)
      SPC 2 
RW    NOP 
DRLU  NOP 
      SPC 2 
* 
*  RWSUB     ROUTINE TO READ OR WRITE A TWO-SECTOR BLOCK
* 
RWSUB NOP 
      DLD RW        FETCH THE NEW POINTERS
* 
* 
      STB RPRM
      SLA,RSS       IF WRITE THEN 
      JMP RWSU1     GO DO IT
      CPB LDRLU     ELSE IF 
      LDB N7        SAME BLOCK AS 
      LDA TRACK     CURRENT ONE 
      CPA LTRAC     THEN
      INB 
      LDA SECT      NO
      CPA LSECT     ACTION IS 
      CLE,INB 
      CPB N5        REQUIRED SO 
      JMP RWSUB,I   RETURN
RWSU1 JSB EXEC      NOT SAME BLOCK  CALL EXEC 
      DEF RTN       RETURN
      DEF RW        READ WRITE CODE 
      DEF RPRM      LU
ABUF  DEF BUF       BUFFER
      DEF .128      128 WORDS 
      DEF TRACK     ON TRACK &
      DEF SECT      SECTOR
RTN   CLA,CLE       CLEAR THE WRITE 
      STA WCS       FLAG
      LDA RPRM      SET UP LAST POINTERS FOR NEXT TIME
      STA LDRLU 
      LDA TRACK     SAVE THE TRACK
      STA LTRAC     ADDRESS AND THE 
      LDA SECT      SECTOR
      STA LTRAC+1   ADDRESS 
      CPB .128      DISC ERR? 
      JMP RWSUB,I   NO - RETURN 
      STA LDRLU     YES; SET NOT IN CORE FLAG 
      JMP EX1       YES - TAKE DISC ERR EXIT
      SPC 2 
LDRLU NOP 
LTRAC NOP 
LSECT NOP 
N5    OCT -5
      SKP 
OPEN  DLD P4        SET NAME WORDS 2 AND  3 
      ELA,CLE,ERA   CLEAR POSSIBLE SCRATCH PURGE BIT
      DST NAME+1    INTO THE NAME BUFFER
      LDA P3        SET NAME WORD1
      RAL,CLE,ERA   LESS POSSIBLE SIGN BIT
      STA NAME      INTO THE NAME BUFFER
      JSB SETDR     SET UP TO READ THE DIRECTORY
      JSB N.SHR     GO FIND THE FILE
      JMP NEXT      NOT FOUND - TRY NEXT DISC 
      JSB SETAD     FOUND - GO SET THE ADDRESSES
      JSB FLAG      CHECK THE OPEN FLAGS
      LDB COUN2     IF 7 OPENS
* 
* 
*    IF SCRATCH PURGE MUST HAVE CLEARED SC PU BIT EARLIER 
*    NOW MUST MAKE SURE ONLY 1 PROG OPEN TO IT(ELSE EX 101?)
*    THEN CLEAR OPEN FLAG 
*         JMP PURGE 
* 
      LDA P4        FETCH POSSIBLE SCR PURGE FLAG 
      SSA           IF SIGN NOT SET--CONTINUE 
      JMP SCPU       ELSE FORCE PURGE 
* 
* 
* 
* 
      CPB .7        THEN NO ROOM SO 
      JMP EX8       EXIT
      LDA P3        IF EXCLUSIVE OPEN 
      CLE,SSA,RSS   THEN SKIP 
      JMP OPEN3     NON EXCLUSIVE  SKIP 
      CCE,SZB       IF ANY OPENS THEN 
      JMP EX8       REJECT EXCLUSIVE OPEN 
OPEN3 LDB SC        GET THE FLAG ADDRESS LESS ONE 
OPEN5 INB           SEARCH FOR OPEN SPOT IN FLAG LIST 
      LDA B,I       GET FLAG WORD 
      SSA           IF SIGN BIT SET THEN
      JMP EX8       FILE IS EXCLUSIVELY OPEN TO SOME ONE
      SZA           THIS WORD?
      JMP OPEN5     NO; GO TRY NEXT ONE 
      LDA ID        YES; GET THE ID ADDRESS 
      RAL,ERA       SET THE EXCLUSIVE/NON-EXCLUSIVE 
      STA B,I       FLAG AND PUT IN THE DIRECTORY 
      STA WCS       SET TO WRITE THE BLOCK
OPEN4 LDA TYPE,I   SET UP THE RETURN PARAMETERS 
      SZA           IF TYPE ZERO SEND BACK ZERO CODE
      LDA #SEC,I    ELSE SEND BACK THE FILE SIZE
CREX  JSB RPRM      SET THE RETURN PRAMS
* 
EXIT  JSB WCSR      WRITE THE SECTOR
      IFZ 
* 
**************************************
*       BEGIN M2\3 VERSION CODE      *
**************************************
* 
      JSB PRTN      PASS THE RETURN PRAMS 
      DEF *+2       AND 
      DEF R1        THEN
EXIT2 JSB EXEC      COMPLETE
      DEF *+2 
      DEF .6
      XIF 
* 
**************************************
*       END M2\3 VERSION CODE        *
**************************************
* 
      SPC 2 
* 
      IFN 
* 
**************************************
*       BEGIN M1 VERSION CODE        *
**************************************
* 
* 
      LDA R1AD      FETCH ADDRESS OF RETURN PARMS 
      LDB XEQT      FETCH IDSEG ADDRESS 
      INB           ADVANCE TO TEMP AREA
* 
*   GO PRIV AND: 1/SET RETURN PARMS INTO ID TEMP AREA 
* 
* 
      JSB PMOVE 
       OCT 5
* 
*     RESET B FOR RAMPAR CALL BY CALLER 
* 
      LDB XEQT
      INB 
      JSB $LIBX 
      DEF TDB 
      NOP 
* 
* 
.5    DEC 5 
R1AD  DEF R1
* 
      XIF 
* 
**************************************
*       END M1 VERSION CODE          *
**************************************
* 
* 
*     EXTENSION OPEN ROUTINE
* 
EXOPN JSB DIRCK     GO READ IN THE MASTER DIRECTORY ENTRY 
      CLA           CLEAR THE 
      STA ID        OPEN FLAG WORD
      LDA P4        SET THE 
      SZA,RSS       IF AFTER THE MAIN THEN
      JMP OPEN4     WE HAVE IT ALREADY
      ALF,ALF       EXTENSION NO FOR POSSIBLE 
      STA GSEC      EXTENSION CREAT 
      JSB EXSHR     SEARCH FOR THE REQUIRED EXTENT
      JMP EXOPT     NOT FOUND SO GO TEST IF READ
      ALF,ALF       EXTENT NO TO A
      AND B377      MASK
      CPA P4        THIS IT?
      JMP OPEN4     YES SO GO RETURN THE PRAMS
CSER  LDA TYPE      NO SO CONTINUE
      JMP NSHR4     THE SEARCH
      SPC 1 
EXOPT LDB P1        IF EXTENT OPEN IS FOR 
      CPB .8        WRITE THE GO CREAT THE EXTENT 
      JMP CREA0     GO EXIT 
      LDA N5        ELSE RETURN ILLEGAL RECORD ERROR
      JMP CREX      GO EXIT 
      SPC 2 
.8    DEC 8 
.14   DEC 14
ANAME DEF NAME
ATRAK NOP 
SIGN  OCT 100000
      SPC 2 
* 
*  SETDR     ROUTINE TO SET UP TO READ A DIRECTORY
* 
SETDR NOP 
      JSB WCSR      WRITE CURRENT SECT
      LDA .128      PRESET # SET TO AVOID DIVIDE
      ISZ FIRST     (EXCEPT WHEN REWRITING) 
      STA ##SEC     PROBLEMS
      CCA           SET FIRST 
      STA FIRST     FLAG TO INDICATE FIRST BLOCK
      LDA ATRAK     SET THE TRACK 
      STA TRACK     ADDRESS 
      LDA ALU       AND THE LU
      STA DRLU      ADDRESS 
* 
* 
      LDA N#FMT     ADD SECTOR BUMP FACTOR(=14 UNTIL1ST BLK READ) 
      STA SECT      SET THE SECTOR
      JMP SETDR,I   RETURN
N14   DEC -14 
* 
* N.SHR     DIRECTORY SEARCH ROUTINE
*           TARGET NAME IN NAME 
*           RETURNS:
*           P+1  END OF DIRECTORY   A=NEXT ADDR. (IF A=0 END OF SPACE)
*           P+2  FOUND RETURN   A=ENTRY ADDR. 
* 
N.SHR NOP 
      JSB RDNXB     READ THE DIRECTORY
      JMP N.SHR,I   END OF DISC RETURN
NSHR0 LDA ABUF      SET A TO THE BUFFER ADDRESS 
      LDB N8        SET COUNT FOR THE NO. IN A BLOCK
      STB COUN1 
NSHR1 CCE           SET FOUND FLAG (E=1)
      LDB ANAME     SET THE NAME ADDRESS
      STB TMP2      IN TMP2 
      LDB N3        SET FOR 3-WORD NAME 
      STB COUN2 
NSHR2 LDB A,I       GET A NAME WORD 
      SZB,RSS       IF ZERO - END OF DIRECTORY
      JMP N.SHR,I   SO EXIT 
      CPB TMP2,I    MATCH?
      INA,RSS       YES - SET FOR NEXT WORD SKIP
      CLE,INA       NO  - SET NOT FOUND - STEP NAME 
      ISZ TMP2      STEP LOCATIONS
      ISZ COUN2     AND COUNT MORE NAME 
      JMP NSHR2     YES; GO DO IT 
      CLB,SEZ,CCE,INB  NO; FOUND? 
      JMP NSHR3     YES; GO TAKE FOUND EXIT 
NSHR4 ADA .13       NO; SET FOR NEXT ENTRY
      ISZ COUN1     DONE WITH BLOCK?
      JMP NSHR1     NO; DO NEXT ENTRY 
      JMP N.SHR+1   YES; GO READ NEXT BLOCK 
NSHR3 ADB N.SHR     FOUND - STEP RETURN ADDRESS 
      ADA N3        ADJUST TO START OF ENTRY
      JMP B,I       RETURN
* 
* SETAD     TO SET UP ADDRESSES FOR DIRECTORY ENTRY IN BUF AT 
*           ADDRESS POINTED TO BY A 
* 
* 
SETAD NOP 
      CLB,CLE 
      JSB P.PAS 
N10   DEC -10 
DIRA  NOP 
      NOP 
      NOP 
TYPE  NOP 
TRAKA NOP 
SECTA NOP 
#SEC  NOP 
RL    NOP 
SC    NOP 
FLAGA NOP 
      JMP SETAD,I 
      SPC 2 
                                                                          