ASMB,R,Q,C
      HED TYPE 5 ID MANAGER FOR RTE II,III & IV 
*     NAM T5IDM,3,40 PRE REL 780224 (MOS) 
*     NAM T5IDM,3,40 09570-16539 REV. A 761013
*     NAM T5IDM,3,40 PRE RELEASE REV. C 780720 (RTE IV) 
      NAM T5IDM,131,40 92067-16469 REV.1903 790222  
* 
* 
*-------------------------------------------------------- 
* 
*     RELOC.       09570-16539
*     SOURCE       09570-18539
* 
*     M. SPANN           24 MAR 77 REV. B 
* 
*     (C) COPYRIGHT HEWLETT-PACKARD COMPANY,1976. 
*     ALL RIGHTS RESERVED.THE INFORMATION CONTAINED ON
*     THIS MEDIUM MAY BE USED WITH ONLY ONE COMPUTER
*     AT A TIME.IT SHALL NOT OTHERWISE BE RECORDED, 
*     TRANSMITTED,OR STORED IN A RETRIEVAL SYSTEM.
*     COPYING OR OTHER REPRODUCTION WITHOUT PRIOR WRITTEN 
*     CONSENT OF HEWLETT-PACKARD COMPANY IS PROHIBITED, 
*     EXCEPT THAT ONE COPY MAY BE MADE AND RETAINED FOR ARCHIVE 
*     PURPOSES ONLY.
* 
*                ---------------
* 
*     THE INFORMATION CONTAINED ON THIS MEDIUM IS PROPRIETARY 
*     TO HEWLETT-PACKARD COMPANY. IT MAY BE USED WITH ONE 
*     COMPUTER ONLY AND IS NOT TO BE DISCLOSED TO ANY THIRD 
*     PARTIES OR REPRODUCED IN ANY FORM EXCEPT THAT IT MAY BE 
*     TRANSFERRED TO ONE BACKUP COMPUTER DURING A COMPUTER
*     MALFUNCTION OR DURING PREVENTIVE MAINTENANCE. 
* 
*---------------------------------------------------------
      ENT T5IDM 
      EXT EXEC,PRTN,NAM..,$OPSY 
      EXT RMPAR,OPEN,CLOSE,FSTAT
      EXT IDSGA,IDRPD,$LIBR,$LIBX 
      EXT DTACH,$CL1,$CL2           * FOR SESSION MONITOR 
* 
A     EQU 0 
B     EQU 1 
KEYWD EQU 1657B 
XEQT  EQU 1717B 
BPA3  EQU 1744B 
TATSD EQU 1756B 
SECT2 EQU 1757B 
SECT3 EQU 1760B 
      SUP 
      SKP 
TSIZE EQU 1270      ROOM FOR 254 ENTRIES
PNTR  NOP           TABLE - 5 
HPNTR NOP 
MPNTR NOP 
BPNTR NOP 
TPNTR NOP 
TABLE EQU *         START OF TABLE
      UNL 
      REP TSIZE 
      DEC -1
      LST 
TEND  DEF *         END OF TABLE + 1
TBLA  DEF PNTR      TABLE - 5 
TBLAD DEF TABLE 
RROBN DEF TEND-5    ROUND ROBIN POINTER 
CRN#  NOP           NUMBER OF DISC LU'S 
CRN   NOP           TOP OF STACK OF DISC LU'S 
* 
DCB   BSS 144       DCB 
SYSID EQU DCB 
      ORG DCB 
      LDA $CL2      CALCULATE THE LAST SECTOR NUMBER OF 
      ADA D2        :CL ON SYSTEM DISC
      STA TEMP      SAVE FOR LATER
      JSB EXEC      GO READ THE :CL OF THE DISC 
      DEF *+7 
      DEF D1
      DEF PRC2      SYSTEM DISC 
      DEF SYSIA 
      DEF D128
      DEF $CL1      :CL TRACK 
      DEF TEMP      & 2ND. SECTOR 
      LDA SYSIA+125 GET SYSTEM SETUP CODE 
      STA SYSUP     AND SAVE FOR LATER USE
      CLA           EXIT TO NEVER RETURN
      STA SYSI1 
      JMP SYSI1 
SYSIA BSS 128 
      ORR 
DUMY  EQU DCB+16-SYSIA ERROR HERE MEANS YOUR IN TROUBLE 
      ORR 
NAME  BSS 4         NAME OF ROOT SEGMT
NUM   NOP           # OF SEGMTS 
TEMP  NOP           TEMPORARY STORAGE 
EFLAG NOP           ERROR FLAG
IERR  NOP           FOR FMGR CALLS
NAME2 NOP           FATHER'S NAME 
      NOP 
      NOP 
      NOP 
ENTR# NOP           NUMBER OF SEGMENTS REMAINING+1
BUFF  EQU DCB       BUFFER FOR CATRIDGE LIST SEARCH 
TAIL  NOP           TEMPORARY 
IDBUF BSS 35        BUFFER FOR HEADER RECORD
ID    EQU IDBUF-1 
DID12 DEF ID+12 
DID23 DEF ID+23 
* 
D0    DEC 0 
D1    DEC 1 
D2    DEC 2 
D3    DEC 3 
D4    DEC 4 
D5    DEC 5 
SEGT  EQU D5
D6    DEC 6 
D11   DEC 11
D12   DEC 12
D14   DEC 14
D15   DEC 15
B17   EQU D15 
B20   OCT 20
D20   DEC 20
D23   DEC 23
D28   DEC 28
D35   DEC 35
B40   OCT 40
B77   OCT 77
B177  OCT 177 
HBIT  OCT 100 
B200  OCT 200 
D128  EQU B200
B220  OCT 220 
B377  OCT 377 
DBLNK OCT 20040 
OM20  OCT -20 
OM360 OCT -360
OM200 OCT -200
MASK  OCT 177400
DM1   DEC -1
DM3   DEC -3
* 
***************************************************** 
      UNL 
PRC   OCT 74000 
PRC2  OCT 74002 
      SKP 
      LST 
* 
*     ! T5IDM INTERNAL CIRCULAR LINKED LIST STRUCTURE ! 
* 
*     LIST POINTER  BACK/FWD
*     NAME1         N/A 
*     NAME2         M/E 
*     NAME/TYPE     A/T 
*     DISC WORD     27TH WRD OF ID
* 
*      CALLING SEQUENCE 
* 
*     :RU,T5IDM,FN,AM,E,#IDS,CRN
* 
***************************************************** 
* 
*     TEST PROGRAM SHOWS PARAMETER PASSING TO SEGMENT 
*FTN,L
*      PROGRAM TEST1
*      DIMENSION IP(5),ITESTA(3)
*      DATA ITESTA/2HTE,2HST,2HA /
*      CALL RMPAR(IP) 
*      CALL CLOVL(ITESTA,IP)
*      STOP 0 
*      END
*      PROGRAM TESTA(5) 
*      DIMENSION IP(5)
*      CALL RMPAR(IP) 
*      WRITE (1,100) IP 
*  100 FORMAT ("THE INPUT PARAMETERS WERE "5I7) 
*      STOP 77
*      END
*      END$ 
* 
*     TEST PROGRAM SHOWS RETURN TO MAIN FROM SEGMENTS 
*FTN,L
*      PROGRAM TEST2
*      DIMENSION ITESTB(3)
*      DATA ITESTB/2HTE,2HST,2HB /
*      CALL RPIDS(ITESTB,5) 
*      CALL CLOVL(ITESTB) 
*      ITESTB(3) = 2HC
*      CALL CLOVL(ITESTB) 
*      ITESTB(3) = 2HD
*      CALL CLOVL(ITESTB) 
*      ITESTB(3) = 2HE
*      CALL CLOVL(ITESTB) 
*      ITESTB(3) = 2HF
*      CALL CLOVL(ITESTB) 
*      STOP 77
*      END
*      PROGRAM TESTB(5) 
*      DIMENSION IDMY(5)
*      EQUIVALENCE (IDMY,IRTN)
*      CALL RMPAR(IDMY) 
*      WRITE (1,100)
*  100 FORMAT ("I AM NOW IN THE TESTB OVERLAY SEGMENT") 
*      GO TO IRTN 
*      END
*      PROGRAM TESTC(5) 
*      DIMENSION IDMY(5)
*      EQUIVALENCE (IDMY,IRTN)
*      CALL RMPAR(IDMY) 
*      WRITE (1,100)
*  100 FORMAT ("I AM NOW IN THE TESTC OVERLAY SEGMENT") 
*      GO TO IRTN 
*      END
*      PROGRAM TESTD(5) 
*      DIMENSION IDMY(5)
*      EQUIVALENCE (IDMY,IRTN)
*      CALL RMPAR(IDMY) 
*      WRITE (1,100)
*  100 FORMAT ("I AM NOW IN THE TESTD OVERLAY SEGMENT") 
*      GO TO IRTN 
*      END
*      PROGRAM TESTE(5) 
*      DIMENSION IDMY(5)
*      EQUIVALENCE (IDMY,IRTN)
*      CALL RMPAR(IDMY) 
*      WRITE (1,100)
*  100 FORMAT ("I AM NOW IN THE TESTE OVERLAY SEGMENT") 
*      GO TO IRTN 
*      END
*      PROGRAM TESTF(5) 
*      DIMENSION IDMY(5)
*      EQUIVALENCE (IDMY,IRTN)
*      CALL RMPAR(IDMY) 
*      WRITE (1,100)
*  100 FORMAT ("I AM NOW IN THE TESTF OVERLAY SEGMENT") 
*      GO TO IRTN 
*      END
*      END$ 
      SKP 
*     EXAMPLE CALLING INTERFACE 
*ASMB,R,L,C 
*      HED "CLOVL" ROUTINE TO CALL IN AN OVERLAY 2-77 (DLB) 
*      NAM CLOVL,7 EXAMPLE ROUTINE TO USE TYPE 5 ID MANAGER 
*      ENT CLOVL,RPIDS
*      EXT IDMG#,IDGT#,EXEC,.ENTR,PAU.E,.DFER 
*      SPC 1
*A     EQU 0
*B     EQU 1
*XEQT  EQU 1717B
*      SPC 1
** PURPOSE (1):  TO PRODUCE AND CALL AN RTE OVERLAY PROGRAM 
**
** CALLING: 
**
**      CALL CLOVL(NAME)
**         -OR- 
**      CALL CLOVL(NAME,IPBUF)
**      <NO POSSIBLE RETURN FROM THIS SUBROUTINE WHEN CALLED THIS WAY>
**
** WHERE: 
**
**      NAME  = 3 WORD BUFFER CONTAINNING SEGMENT PROGRAM NAME. 
**      IPBUF = OPTIONAL 5 WORD BUFFER TO PASS TO SEGMENT PROGRAM.
**
** PURPOSE (2):  TO PRODUCE MULTIPLE SHORT IDSEGMENTS SO THAT THEIR SIZE
**           CAN BE EXAMINED. 
**
** CALLING: 
**
**      CALL RPIDS(NAME,NUMBR)
**
** WHERE: 
**
**      NAME  = 3 WORD BUFFER CONTAINNING SEGMENT PROGRAM NAME. 
**      NUMBR = NUMBER OF SEGMENTS THAT NEED TO BE PRODUCED, WHERE
**              THE LAST NON-BLANK CHARACTER WILL BE INCREMENTED TO 
**              DETERMINE THE NEXT NAME TO BE USED. 
**
**
*      SPC 1
*NAME  NOP
*PRAMS DEF *+1       DEFAULT CALLED ADDRESS (IF FROM ROOT CODE) 
*CLOVL NOP
*      JSB .ENTR
*DFNAM DEF NAME 
*      LDA PRAMS     GET PARAMETER BUFFER ADDRESS 
*      STA PRMBF+0
*      INA
*      STA PRMBF+1
*      INA
*      STA PRMBF+2
*      INA
*      STA PRMBF+3
*      INA
*      STA PRMBF+4
*      LDA DFNAM     RESET THE OPTIONAL PARAMETER ADDRESS WORD
*      ADA O2 
*      STA PRAMS
*AGAIN JSB EXEC      CALL THE OVERLAY 
*      DEF *+8
*      DEF NA8       NO ABORT CALL EXEC (8
*      DEF NAME,I 
*PRMBF REP 5
*      DEF *
*      LDA NAME      GET NAMES DIRECT ADDRESS 
*      JSB IDMG#     USE T5IDM TO PRODUCE THE OVERLAY 
*      JSB EXEC      NOW TRY AGAIN
*      DEF *+8
*      DEF NA8
*      DEF NAME,I 
*      DEF PRMBF+0,I
*      DEF PRMBF+1,I
*      DEF PRMBF+2,I
*      DEF PRMBF+3,I
*      DEF PRMBF+4,I
*      JSB .DFER     MOVE THE SEGMENT NAME INTO THE MESSAGE BUFFER
*      DEF MESS 
*      DEF NAME,I 
*      LDA XEQT      GET ADDRESS OF MY OWN NAME 
*      ADA D12       INDEX INTO THE IDSEGMENT 
*      LDB A,I       GET 1ST TWO CHARS
*      STB PNAME
*      INA
*      DLD A,I       GET LAST FOUR CHARS
*      STA PNAME+1   SAVE CHARS 3 & 4 
*      LSR 8         STRIP OFF LAST CHAR
*      BLF,BLF       REPOSITION 
*      ADB O40
*      STB PNAME+2   SET THE LAST CHAR + SPACE
*      JSB EXEC      NOW WRITE OUT THE NOT FOUND MESSAGE
*      DEF *+5
*      DEF O2        WRITE
*      DEF PAU.E     USE SAME LU AS THE "STOP" ROUTINE
*      DEF MESS 
*      DEF D15
*      JSB EXEC      NOW PAUSE
*      DEF *+2
*      DEF O7        NOW PAUSE FOR ID TO BE PRODUCED
*      JMP AGAIN     NOW TRY SAME ALL OVER AGAIN
*      SPC 1
*O2    OCT 2
*O7    OCT 7
*D12   DEC 12 
*D15   DEC 15 
*O40   OCT 40 
*NA8   OCT 100010 
*MESS  ASC 7,PROGA MISSING-PROGM SUSPENDED! 
*PNAME ASC 3,PROGM SUSPENDED! 
*      ASC 5,SUSPENDED! 
*NAME1 NOP
*NUMBR NOP
*RPIDS NOP
*      JSB .ENTR     GET CALLERS PARAMETERS 
*      DEF NAME1
*      LDA NAME1     GET ADDRESS OF SEGMENT NAME
*      LDB NUMBR,I   GET THE NUMBER OF SEGMENTS NECESSARY 
*      JSB IDGT#     CALL TYPE 5 ID MANAGER INTERFACE ROUTINE 
*      JMP RPIDS,I   RETURN DONE
*      END
      SKP 
*ASMB,R,L,C 
*      HED TYPE 5 MANAGER INTERFACE 
**     NAM IDGT#,7 PRE-REL 7-22-76 (MOS)
**     NAM IDGT#,7 09570-16499 REV. A 761013
**     NAM IDGT#,7 PRE-REL 770213 (DLB) 
*      NAM IDGT#,7 PRE-REL 780402 (DLB) (RTE-IV)
**
**--------------------------------------------------------
**
**     RELOC.       09570-16499 
**     SOURCE       09570-18499 
**
**     M. SPANN           13 OCT 76 REV.
**
**--------------------------------------------------------- 
**
*      ENT IDGT#,IDMG#
*      EXT EXEC,.XLB
**
*A     EQU 0
*B     EQU 1
*XEQT  EQU 1717B
*TAT   EQU 1656B
*TATSD EQU 1756B
**
*IDMG# NOP
*      LDB IDMG#
*      STB IDGT#
*      CLB,INB,RSS
*IDGT# NOP
*      STB IDMG#     SAVE NUMBER OF MODULES TO :RP, 
*      STA TEMP 
*      INA
*      STA TEMP+1 
*      INA
*      STA TEMP+2 
*      LDA XEQT      GET IDSEGMENT ADDRESS OF THIS PROGRAM
*      ADA D26       BUMP TO THE DISC ADDRESS WORD
*      JSB .XLB      GET THE DISC ADDRESS WORD
*      DEF A,I       * LDB A,I
*      CLE,ELB       GET THE DISC LU IN E-REG 
*      LSR 8         POSITION DISC TRACK TO LO 8 BITS 
*      CLA,SEZ       CHECK IF ON LU = 3 
*      ADB TATSD     YES, LU = 3, ADD IN TRACKS IN LU = 2 
*      ADB TAT       INDEX INTO THE TAT TABLE 
*      JSB .XLB      GET THE VALUE IN THE TAT TABLE 
*      DEF B,I       * LDB B,I
*      CPB FMPTK     CHECK IF IS ON A FMGR TRACK? 
*      CLA,INA,RSS   YES, CONTINUE
*      JMP EXIT      NO, SKIP CALL TO T5IDM 
*      ELA           NOW CALCULATE IF ON LU = 2 OR 3
*      CMA,INA       MAKE NEGATIVE
*      STA CRN       AND SET TO CRN = -2 OR -3
*      JSB EXEC 
*      DEF RTN
*DEFER DEF SCHD 
*      DEF T5IDM
*TEMP  NOP           PARAMETERS TO PASS 
*      NOP
*      NOP
*      DEF IDMG#     NUMBER OF SEGMENTS 
*      DEF CRN       THE CARTRAGE OF THIS PROGRAM 
*RTN   NOP           T5IDM NOT FOUND
*EXIT  JMP IDGT#,I
**
*SCHD  OCT 100027 
*D26   DEC 26 
*FMPTK OCT 77776
*T5IDM ASC 3,T5IDM
*CRN   NOP
*      END
      SKP 
T5IDM JSB RMPAR     GET SCHED PARMS 
       DEF *+2
       DEF NAME 
SYSI1 JMP SYSID     ONE TIME CODE 
      LDA NUM       GET USER SPECIFIED DISC LU
      SSA,RSS       MAKE SURE IT'S NEGATIVE 
      CMA,INA 
      STA CRN       AND SAVE
      LDA NAME+3    GET NUMBER OF SEG FROM USER 
      SZA           IF HE SPECIFIED 0 
      SSA           OR NEGATIVE 
      CLA,INA       DEFAULT TO 1
      STA NUM       SAVE
      STA ENTR# 
*     DO THE DOUG BASKINS' TABLE FLUSH
      LDB BPA3      GET START OF BCKGND BP
      CPB D2        IF RTE III OR IV
      CPA D1        AND LONG REQUEST
      JMP T50       SKIP IF SHORT OR RTE II 
      LDB TBLA      GET START OF TABLE
      STB IDBUF      SAVE TEMP
T5    LDB IDBUF     LAST ENTRY PROCESSED
      ADB D5        BUMP TO NEXT
      CPB TEND      END OF TABLE ?
      JMP T50       YES - DONE
      STB IDBUF     SAVE POINTER
      ADB D3        TYPE STATUS WORD
      LDA B,I       GET IT
      CPA DM1       VALID DATA ?
      JMP T50       NO
      AND B17       EXTRACT TYPE
      CPA D3        TYPE 3 ?
      JMP T5        YES - SKIP
      LDB IDBUF     CURRENT ENTRY 
      JSB FLUSH     TRY TO DO AN RP,, 
      JMP T5        TRY NEXT
* 
T50   LDA NAME+1    SECOND WORD OF NAME 
      SZA,RSS       IF NULL 
      LDA DBLNK     DEFAULT TO BLANK
      STA NAME+1    RESTORE 
      AND B377      LOOK AT LOW BYTE
      SZA           IF NULL 
      JMP T51       NOT NULL
      LDA B40 
      IOR NAME+1    ADD BLANK 
      STA NAME+1    RESTORE 
T51   LDA NAME+2    GET 3RD WORD OF NAME
      SZA,RSS       IF NULL 
      LDA DBLNK     DEFAULT TO BLANK
      AND MASK      SAVE 5TH CHARACTER
      IOR B40       PUT BLANK IN 6TH POSITION 
      STA NAME+2       SO MATCH WILL WORK 
      CLA,CLE 
      STA HPNTR     INITIALIZE HEAD POINTER 
      STA EFLAG     ZERO ERROR COUNT
      SKP 
SRCH  CLA           INITIALIZE
      STA BPNTR     BLANK POINTER 
      STA MPNTR     MATCH POINTER 
      LDB TBLAD     TABLE ADDRESS 
LOOP  STB PNTR      POINTER FOR SEARCH LOOP 
      LDA B,I       GET LINK WORD 
      SZA,RSS       IS IT A BLANK ? 
      JMP BLANK     -YES- 
      CPA DM1       END OF ENTRIES ?
      JMP ENTR      YES 
      JSB MATCH     IS IT ONE WE WANT ? 
       DEF NAME 
       STB MPNTR    YES-SAVE ADDRESS
      AND HBIT      [A] IS TYPE/STATUS
      SZA,RSS       IS ENTRY A HEAD ? 
      JMP NEXT      NO
      CPB MPNTR     IS HEAD A MATCH ? 
      STB HPNTR     YES SAVE ADDRESS
      JSB GOBCK    LOOK AT TAIL OF LIST 
      CPA D3        IS IT A TYPE 3 (FATHER) ? 
      RSS           YES 
      JMP NEXT      NO CHECK NEXT ENTRY 
CHCK  JSB DRMNT     REMOVE DORMANT TYPE 3 FROM LIST 
      CPA D3        IS BACK TYPE 3? 
      JMP CHCK      YES- CHECK IT 
      JSB GOFWD     SEE IF ANY TYPE 3'S REMAIN
      CPA D3
      JMP NEXT      YES - LIST STILL MUST REMAIN
CHC2  JSB FLUSH     DO RP,, THING 
      JSB GOFWD     UNTILL
      CPA SEGT      SKIP WHEN BACK TO HEAD
      JMP CHC2
NEXT  LDB PNTR      BUMP POINTER
      ADB D5        TO NEXT ENTRY 
      CPB TEND      END OF TABLE ?
      JMP ENTR      YES 
      JMP LOOP      CONTINUE CHECKING 
* 
BLANK LDA BPNTR     PREVIOUS BLANK ?
      SZA,RSS       YES-SKIP
      STB BPNTR     SAVE ADDRESS OF BLANK ENTRY 
      JMP NEXT
      SKP 
*                   *TABLE HAS BEEN UPDATED ,CHECK ON CALLER
ENTR  LDB XEQT      OUR ID ADDRESS
      ADB D20       21'ST WORD
      LDA B,I 
      AND B377      EXTRACT FATHER'S ID # 
      SZA,RSS       DO WE HAVE A FATHER ? 
      JMP EXIT      NO! 
      ADA DM1       WHY ??? 
      ADA KEYWD      CALCULATE HIS ID ADDRESS 
      LDA A,I       GET ID ADDRESS
      ADA D12       POINT TO HIS NAME 
      LDB A,I       GET 1ST WORD OF HIS NAME
      INA 
      STB NAME2     SAVE
      LDB A,I       GET 2ND WORD
      SZB,RSS       IF NULL 
      LDB DBLNK     DEFAULT TO BLANK
      STB NAME2+1   SAVE
      INA 
      LDB D12       ADD 12 TO POINT TO
      ADB A         DISC ADD
      LDA A,I       GET 3RD WORD
      SZA,RSS       IF NULL 
      LDA DBLNK     DEFAULT TO BLANK
      AND MASK      SAVE 5TH CHARACTER
      IOR B40       PUT IN BLANK FOR MATCH
      STA NAME2+2   SAVE
      LDA B,I       GET DISC ADD
      STA NAME2+3   SAVE
      LDB DM3       LU=3
      SSA,RSS       OR
      INB           LU=2
      LDA CRN       LU SPECIFIED? 
      SZA,RSS       WELL??
      STB CRN       NO USE POP'S
      JSB NAM..     CHECK IF NAME IS LEGAL ?
       DEF *+2
       DEF NAME 
      SZA 
      JMP ERMOR     NOT LEGAL SO RECORD ERROR 
      LDB MPNTR     DID WE FIND A MATCH ? 
      SZB,RSS 
      JMP NMTCH     MATCH NOT FOUND 
*     MATCH FOUND IN TABLE
      STB BPNTR     SET POINTER FOR OPEN
      ADB D4        ADDRESS OF DISC WORD
      LDA B,I       CHECK THE DISC WORD 
      SZA           DO WE HAVE A DISC ADDRESS ? 
      CPA DM1 
      JMP NMTCH     NO - OPEN FILE
      CLE,ELA       PUT LU IN E REG.
      LDA CRN       USER SPECIFIED LU 
      RAR,ELA       PUT E REG. IN LSB 
      CPA CRN       STILL SAME ?
      JMP ENT0      YES-THEY AGREE
* 
ENL0  LDB MPNTR     WE GOT THE WRONG DUDE !!! 
      JSB GOBCK     SEE IF WE CAN CHANGE HORSES 
      CPA D3        TYPE THREE ?
ENL1  JSB DRMNT     IF DORMANT REMOVE FROM LIST 
      CPA D3        IS BACK TYPE 3 ?
      JMP ENL1      YES - KEEP TRYING 
      JSB GOFWD     SEE IF ANY TYPE THREES
      CPA D3        REMAIN
      JSB ENL4      CHECK IF SAME FATHER ON DIFF LU.
ENL3  JSB GOBCK     BACK AROUND LIST
      CLA           CLEAR OUT OLD DATA
      ADB D4        BUMP TO DISC WORD 
      STA B,I       CLEAR IT
      ADB DM4       RESTORE B REG.
      JSB FLUSH     TRY RP,, IN CASE
      SZA           IF SUCCESS
      CPA D14       OR NOT FOUND
      CPB MPNTR      CHECK FULL CIRCLE
      JMP NMTCH     YES -GO OPEN CORRECT FILE 
      JMP ENL3      KEEP ON TRUCKING
* 
ENL4  NOP 
      JSB MATCH     SEE IF SAME FATHER
       DEF NAME2
      RSS           YES SKIP
      JSB ERR       GET OUT GRACEFULLY
      ADB D4        BUMP TO DISC WORD 
      LDA B,I       GET IT
      CLE,ELA       LU TO E REG.
      LDA CRN       USER SPECIFIED LU 
      RAR,ELA       REPLACE LSB 
      CPA CRN       STILL SAME ?
       JSB ERR      YES - GET OUT 
      LDA NAME2+3   GET NEW DISC WORD 
      STA B,I       PUT IN ENTRY
      ADB DM4       RESTORE B REG.
      JMP ENL4,I    RETURN
* 
ENT0  JSB IDSGA     SEE IF NOW IN CORE
       DEF *+2
       DEF NAME 
      SZA           IN CORE ? 
      JMP ENTR1     YES 
      LDB BPNTR     ENTRY ADDRESS 
      ADB D4
      LDA B,I       GET DISC WORD 
      RAL,CLE,ERA   PUT LU IN E REG 
      STA B 
      AND B177      EXTRACT SECTOR
      STA DCB+4     PUT IN DCB WORD 
      XOR B         REMOVE SECTOR FROM B
      ALF,ALF       POSITION
      RAL 
      STA DCB+3     PUT IN DCB
      LDA SECT2     IF LU=2 
      SEZ 
      LDA SECT3     LU=3
      STA DCB+8     PUT IN DCB
      CLA,INA       FORM DISC LU
      ELA           IF E SET IT'S LU=3
      STA DCB       PUT IN DCB
      LDB XEQT      GET OUR ID ADDRESS
      STB DCB+9     SHOW FILE OPEN TO US
      JSB LOOK      READ FILE HEADER
       JMP RPACK     CHECKSUM ERROR 
      LDB DID12     NAME IN FILE HEADER 
      JSB MATCH     SEE IF SAME AS
DNAME  DEF NAME      REQUESTED NAME 
      RSS             YES - SKIP
      JMP ENL0      TRY FOR DESIRED ONE 
ENT00 JSB FID       DO RP THING 
      SZA           ANY ERROR ? 
      CPA D23       DUPLICATE ID ?
      JMP ENTR1     DUP OR NO ERROR 
      CPA D14       NO ID AVAILABLE ? 
      JSB ROBIN     MAKE AN ID AVAILABLE
       JMP ERMOR    NONE AVAILABLE
      JMP ENT00     TRY AGAIN 
* 
RPACK LDB TBLAD     TABLE ADDRESS 
      CLA 
RPK   CPB TEND      END OF TABLE ?
      JMP NMTCH     YES - GO OPEN FILE
      ADB D4        WORD 5
      STA B,I       CLEAR DISC WORD 
      INB 
      JMP RPK       LOOP FULL TABLE 
      SKP 
*  *NOW MAKE ENTRY IN OUR TABLE 
ENTR1 LDB HPNTR     HEAD POINTER
      SZB           FOUND ? 
      JMP ENTR3     YES 
      LDB BPNTR     NOT FOUND SEARCH
NTRL  JSB GOBCK     LOOK BACK 
      AND HBIT
      SZA,RSS       IS THIS THE HEAD OF THIS LIST ? 
      CPB BPNTR     LIST EXHUSTED ? 
      RSS           SKIP
      JMP NTRL      NO KEEP LOOKING 
      STB HPNTR     SAVE HEAD ADDRESS 
      ADB D3
      LDA B,I       GET WORD 4
      IOR HBIT      MARK AS HEAD
      STA B,I       IN ENTRY
ENTR2 LDB HPNTR 
      JMP EN1       LOOK FOR FATHER 
* 
ENTR3 CPB BPNTR     IF ENTRY IS HEAD
      JMP EN1       LOOK FOR FATHER 
      LDB BPNTR     OTHERWISE 
      JSB GOFWD     CHECK 
      CPB BPNTR     IF ONLY ENTRY 
      RSS           YES - SKIP
      JMP ENTR2     NO
      LDB HPNTR     HEAD OF NEW LIST
      JSB GOFWD 
      LDA B         LINK IN FRONT OF NEW HEAD 
      LDB BPNTR 
      JSB INSRT 
      LDA DNAME     GET NAME ADDRESS
      INB           BUMP TO WHERE NAME GOES 
      JSB MOVE
       DEC -4 
      JMP ENTR2 
      SKP 
EN0   JSB MATCH     IS THIS FATHER
DNAM2  DEF NAME2     FATHER'S NAME
       JMP MORE?    YES-ALREADY IN LIST 
EN1   JSB GOBCK     LOOK BACK 
      CPA D3        IS THIS A FATHER ?
      JMP EN0       YES-SEE IF IT'S OURS
*                   FATHER NOT IN LIST MAKE ENTRY 
      JSB QBLNK     LOOK FOR BLANK
      SZB,RSS       FOUND ONE ? 
      JMP MORE?     NO-CHECK FOR MORE 
      LDA NAME2+2   GET WORD 4
      AND MASK      SAVE 5TH CHAR OF NAME 
      IOR D3        PUT IN TYPE 
      STA NAME2+2   PUT IN ENTRY
      LDA HPNTR     HEAD ADDRESS
      JSB INSRT     INSERT BEHIND HEAD
      LDA DNAM2     FATHERS' NAME ADDRESS 
      INB           WHERE IT GOES 
      JSB MOVE
       DEC -4 
      SKP 
*                   *MORE THAN 1 SEGMENT ?
MORE? LDA ENTR#     GET ENTRY NUMBER
      ADA DM1       SUBTRACT 1
      STA ENTR# 
      CCE,SZA,RSS   MORE? 
      JMP EXIT      NO- 
      LDA NAME+2    GET 3RD. WORD OF NAME 
      AND MASK      STRIP TYPE/STATUS 
      IOR B40       PUT IN BLANK
      STA NAME+2    AND RESTORE 
      LDB DNAM      ADDRESS OF SEG NAME 
      ADB D2        START WITH 3RD. WORD
NOT   LDA B,I       GET WORD
      SEZ           E=0,LOW BYTE
      ALF,ALF       POSITION HIGH TO LOW
      AND B377      MASK
      CPA B40       IF BLANK
      CPB DNAM      OR ONE CHAR NAME
      JMP NOT1      DONE
      CMB,SEZ,CME,INB IF NOW HIGH BYTE
      CMB,RSS       DECREMENT B WITHOUT SETTING E-REG 
      CMB,INB       BACK UP ONE WORD
      JMP NOT 
NOT1  LDA B,I       GET THE WORD
      SEZ           IF HIGH BYTE
      ALF,ALF       SHIFT TO LOW
      SEZ,INA       INCREMENT NAME
      ALF,ALF       REPOSITION
      STA B,I       RESTORE 
      JMP SRCH      SEE IF IT IS IN LIST
* 
ERMOR ISZ EFLAG     COUNT ERRORS
      JMP MORE?     MORE SEGMENTS ? 
      SKP 
*                   *HERE IF ENTRY NOT FOUND IN TABLE 
NMTCH JSB IDSGA     SEE IF ALREADY IN CORE
       DEF *+2
DNAM   DEF NAME 
      SZA           IN CORE ? 
       JMP MORE?    YES 
      CCB           DETERMINE DISK LU 
      STB CRN#      DEFAULT TO ONE DISC 
      LDA CRN       USER SPECIFIED DISC 
      SZA           IF IT IS ZERO 
      CLB,RSS       NOT ZERO USE IT 
      LDA DM2       ZERO - SO DEFAULT IS LU 2 
      STA CRN       SAVE FOR OPEN 
      SZB           USER SPECIFIED LU ? 
      LDB SECT3     NO - DO WE HAVE AN LU 3 ? 
      SZB,RSS       USER SPECIFIED OR NO LU 3 
      JMP NMCH1     GO DO OPEN '(A)_DISC LU'
      JSB FSTAT     REQUEST CATRIDGE LIST 
       DEF *+2
ADBUF  DEF BUFF      BUFFER 
      LDB ADBUF     ADDRESS OF BUFFER 
CLOP  LDA B,I       ENTRY 
      SZA,RSS       END OF LIST ? 
      JMP NMCA      YES 
      AND B77       MASK OF LU
      CPA D2        LU=2 ?
      JMP FOUND     YES 
      CPA D3        LU=3 ?
      JMP FOUND     YES 
      ADB D4        BUMP ADDRESS
      JMP CLOP      KEEP LOOKING
FOUND CMA,INA       MAKE LU NEGATIVE
      STA CRN       SAVE
      LDB DM2       NOW HAVE TWO
      STB CRN#      DISC LU'S 
NMCA  LDA CRN 
NMCH1 STA TEMP      FOR OPEN
      JSB OPEN     OPEN THE FILE
       DEF ORTN      RETURN 
       DEF DCB
       DEF IERR 
       DEF NAME 
       DEF D1        NON-EXCLUSIVE OPEN 
       DEF D0        SECURITY 
       DEF TEMP      LU 
ORTN  CPA D6        DID WE OPEN TYPE 6 ?
      JMP NMCH2     YES - GOOD OPEN 
      LDB CRN#      GET NUMBER OF DISC LU'S TO SEARCH 
      LDA TEMP      WHERE WE LOOKED 
      CPA CRN       TOP OF STACK ?
      CPB DM1       AND MORE THAN 1 DISC LU ? 
      JMP NMC14     NO - NOT FOUND ,CLOSE THE DCB 
      SLA,INA,RSS   TRY OTHER DISC
      LDA DM3 
      JMP NMCH1 
* 
NMCH2 LDA TEMP      RETREIVE DISC LU
      STA CRN       ALL SEGMT'S MUST BE ON SAME LU
      JMP NMCH3     SKIP
NMC12 LDB NUM       REQUESTED NO. OF SEGMENTS 
      CPB D1        SHORT REQUEST 
      JSB ROBIN     MAKE AN ID AVAILABLE
       JMP NMC14    NONE AVAILABLE
NMCH3 LDA CRN       RETREIVE DISC LU
      CMA,INA       MAKE POSITIVE 
      JSB LOOK      READ FILE HEADER
       JMP NMC14    CHECKSUM ERROR
      LDB DID12     CHECK NAME IN FILE HEADER 
      JSB MATCH     MUST MATCH
DNAMN  DEF NAME      NAME REQUESTED 
      RSS           OK
      JMP NMC14     NO GO - CLOSE FILE
      JSB FID       DO THE RP 
      SZA,RSS       ANY ERRORS ?
      JMP NMCH5     SUCCESS 
      CPA D14       NO ID AVAILABLE ? 
      JMP NMC12     YES - TRY TO FREE AN ID 
* 
NMC14 JSB CLOSE     CLOSE DCB 
       DEF *+2
       DEF DCB
      JMP ERMOR     TAKE ERROR EXIT 
* 
NMCH5 JSB CLOSE     CLOSE DCB 
       DEF *+2
       DEF DCB
* 
      LDA NAME+2    MAKE UP ENTRY FOR SEGMENT 
      AND MASK      SAVE 5TH CHARACTER
      IOR SEGT      INSERT TYPE 
      LDB NUM       REQUESTED NO OF ENTRIES 
      CPB ENTR#     IF FIRST ENTRY
      IOR HBIT      IT'S A HEAD 
      STA NAME+2
      LDB HPNTR     ADDRESS OF HEAD 
      JSB GOFWD     ADVANCE FORWARD 
      STB TEMP      SAVE LINK ADDRESS 
      LDB BPNTR     ENTRY ADDRESS TO B
      SZB,RSS       DO WE HAVE A BLANK ?
      JSB QBLNK     FIND ONE
      STB BPNTR     SAVE ADDRESS
      SZB,RSS       FOUND ? 
       JSB ERR      NO - TABLE FULL 
      CPB MPNTR     DID WE FIND IN TABLE ?
      JMP NMCH6     YES 
      LDA TEMP      LINK ADDRESS TO A 
      JSB INSRT     INSERT IN FRONT OF HEAD 
NMCH6 LDA DNAMN     ADDRESS OF NAME 
      INB           WHERE IT GOES 
      JSB MOVE
DM4    DEC -4 
      LDA HPNTR     DID WE HAVE A HEAD ?
      SZA,RSS 
      LDA BPNTR     N0 - NEW ENTRY IS HEAD
      STA HPNTR 
      JMP ENTR1     GO PUT FATHER IN LIST 
      SKP 
      HED TERMINATE SAVING RESOURCES AND REPORT STATUS
ERR   NOP 
      LDA *-1       GET ERROR ADDRESS 
      STA NAME2     REPORT
      CLA,CCE,RSS 
EXIT  CLA,CLE 
      LDB EFLAG     GET ERROR COUNT 
      SZB           ANY ERRORS ?
      CLA,CCE       YES REPORT !
      ERA 
      STA EFLAG 
      JSB DTACH     RELEASE SELF FROM SESSION 
      DEF *+1 
      JSB PRTN      RETURN ANY ERROR
       DEF *+2       TO CALLER
       DEF EFLAG
      JSB EXEC
       DEF *+9
       DEF D6        TERMINATE
       DEF D0        ME 
       DEF D1        SAVING RESOURSES 
       DEF D0        CLEAR OUT XTEMP
       DEF D0        CLEAR OUT XTEMP
       DEF D0        CLEAR OUT XTEMP
       DEF D0        CLEAR OUT XTEMP
       DEF D0        CLEAR OUT XTEMP
      JMP T5IDM 
      SKP 
      HED SUBROUTINES 
*     [B] ADDRESS OF ENTRY
*     JSB MATCH 
*      DEF NAME   NAME TO MATCH 
*     <P+1> IF MATCH
*     <P+2> IF NO MATCH 
*     [A] TYPE/STATUS OF ENTRY
* 
MATCH NOP 
      STB TPNTR     SAVE ENTRY ADDRESS
      LDA MATCH,I   GET NAME ADDRESS
      ISZ MATCH     <P+1> 
      STA TEMP      SAVE NAME ADDRESS 
      INB 
      DLD B,I       1ST TWO WORDS OF ENTRY NAME 
      CPA TEMP,I    SAME ?
      RSS           YES-POSSIBLE MATCH
      JMP NXIT      TAKE NO MATCH EXIT
      ISZ TEMP      BUMP NAME POINTER 
      CPB TEMP,I    COMPARE ? 
      RSS           SAME
      JMP NXIT      NO MATCH
      LDB TPNTR     FIND ADDR OF LAST WORD
      ADB D3        IE WORD 4 
      ISZ TEMP
      LDA B,I       GET LAST CHAR 
      AND MASK
      IOR B40       BLANK 
      CPA TEMP,I    SAME ?
      JMP MXIT      MATCH ! 
NXIT  ISZ MATCH     <P+2> 
      LDB TPNTR     ENTRY ADDRESS 
      ADB D3        POINT TO
MXIT  LDA B,I       TYPE STATUS 
      AND B377      EXTRACT 
      LDB TPNTR     RESTORE ADDRESS 
      JMP MATCH,I   RETURN
* 
*     FIND A BLANK ENTRY IF IT EXISTS IN TABLE
* 
QBLNK NOP 
      LDB TBLAD     TABLE ADDRESS 
      RSS 
QLP   ADB D5        BUMP TO NEXT ENTRY
      CPB TEND      END OF TABLE ?
      CLB,RSS       YES 
      LDA B,I       GET ENTRY'S LINK WORD 
      CPA DM1       UNUSED ENTRY ?
      CLA           YES - USE AS BLANK
      SZB           END OF TABLE ?
      SZA,RSS       OR BLANK FOUND ?
      JMP QBLNK,I   RETURN
      JMP QLP       ELSE
      SKP 
* 
*     [A] LINK POINTER - INSERT BEFORE
*     [B] ENTRY POINTER 
*     JSB INSRT 
* 
INSRT NOP 
      STA TEMP
      STB TPNTR 
      LDA TBLA      TABLE ADDRESS 
      CMA,INA 
      ADA TPNTR     CALCULATE NEW ENTRY LINK
      CLB 
      DIV D5
      STA B         SAVE IN B 
      BLF,BLF       POSITION TO HIGH BYTE 
      IOR B         MERGE TOGETHER
      LDB TEMP      GET LINK POINTER
      SZB,RSS       START OF NEW LIST ? 
       JMP INSR1    YES 
      STA IERR      TEMPORARY 
      LDA B,I       BACK UP 
      ALF,ALF 
      AND B377      EXTRACT BACK LINK 
      MPY D5
      ADA TBLA      ADDR OF PREVIOUS
      STA TAIL      SAVE TAIL ADDRESS 
      LDA TAIL,I    GET TAIL POINTERS 
      LDB TEMP,I    AND HEAD POINTERS 
      RRL 8 
      ALF,ALF       REVERSE LINKS 
      STA TPNTR,I   PUT IT IN ENTRY 
      LDA IERR      RETREIVE TEMPORARY
      CPB TAIL,I    SPECIAL CASE ?
       JMP *+3      YES TWO ENTRY LIST
      RRR 8 
      STB TEMP,I    NEW HEAD POINTERS 
      STA TAIL,I    NEW TAIL POINTERS 
      LDA TPNTR,I   NEW ENTRY POINTERS
INSR1 STA TPNTR,I   PUT IN NEW LINKS
      LDB TPNTR 
      JMP INSRT,I   RETURN
      SKP 
* 
*     [B] ENTRY ADDRESS 
*     JSB GOFWD OR GOBCK
*     [A] TYPE STATUS 
*     [B] NEXT ENTRY IN LIST ADDRESS
* 
GOFWD NOP 
      LDA B,I 
      SZB           IF NO ADDRESS 
      SZA,RSS       OR NO LINK
      JMP GOFWD,I   RETURN
      AND B377      GET FWD LINK
      MPY D5
      ADA TBLA      CALCULATE 
      STA B         SAVE ADDRESS IN B REG.
      ADA D3
      LDA A,I       GET WORD 4
      AND B377      EXTRACT TYPE/STATUS 
      JMP GOFWD,I 
* 
GOBCK NOP 
      LDA B,I 
      SZB           IF NO ADDRESS 
      SZA,RSS       OR NO LINK
      JMP GOBCK,I   RETURN
      ALF,ALF 
      AND B377      GET BACK LINK 
      MPY D5
      ADA TBLA
      STA B         ADDRESS OF PREVIOUS ENTRY 
      ADA D3
      LDA A,I       WORD 4
      AND B377      EXTRACT TYPE/STATUS 
      JMP GOBCK,I 
      SKP 
*     [B] ADDRESS OF ENTRY
*     JSB DRMNT     CHECK IF PRGM DORMANT 
*     [A] TYPE STATUS 
*     [B] ADDRESS OF NEXT ENTRY 
* 
DRMNT NOP 
      STB TPNTR     SAVE CURRENT POINTER
      INB           ADDRESS OF NAME IN ENTRY
      STB DDEF      FOR CALL
      JSB IDSGA     GET ID ADDRESS
       DEF *+2
DDEF   NOP          NAME ADDRESS
      LDB TPNTR     RESTORE POINTER 
      SZA,RSS       DOES IT EXIST ? 
      JMP RMOVE     N0-DORMANT
      ADA D15       STATUS WORD FROM ID 
      LDA A,I 
      AND B17       EXTRACT STATUS
      SZA,RSS       0=DORMANT 
      JMP RMOVE     DORMANT SO REMOVE FROM LIST 
      JSB GOBCK     LOOK AT BACK
      JMP DRMNT,I 
* 
RMOVE STB TAIL      IF ONLY ENTRY 
      JSB GOBCK     GET ADDRESS OF BACK 
      CPB TPNTR     IF ONLY ENTRY 
      JMP RXIT      JUST MARK AS BLANK
      STB TAIL      SAVE TAIL ADDRESS 
      LDA B,I       GET LINK WORD 
      AND MASK      GET BACK
      STA TEMP      SAVE
      LDA TPNTR,I 
      AND B377      GET ENTRY'S FWD LINK
      IOR TEMP      FORM NEW LINK 
      STA B,I       NEW LINK FOR BACK 
      LDB TPNTR 
      JSB GOFWD     ADDRESS OF FORWARD
      LDA B,I 
      CPB TAIL      ONLY TWO ENTRIES ?
      LDA TPNTR,I   YES - SPECIAL CASE
      AND B377      EXTRACT ITS FWD 
      STA TEMP      AND SAVE
      LDA TPNTR,I   GET ENTRIES FROM BACK 
      AND MASK
      IOR TEMP      FORM NEW LINK 
      STA B,I       PUT IN FORWARD'S LINK WORD
RXIT  LDB TPNTR     RESTORE B 
      CLA 
      STA B,I       MARK ENTRY AS BLANK 
      LDB TAIL      RETURN WITH BACK ADDR 
      LDA B 
      ADA D3
      LDA A,I 
      AND B377      AND TYPE/STATUS 
      JMP DRMNT,I   RETURN
      SKP 
* 
*     [B] ENTRY ADDRESS 
*     JSB FLUSH - DO RP ,, ON ENTRY'S ID
*     [A] ERROR CODE
*     [B] UNCHANGED 
FLUSH NOP 
      STB TPNTR     SAVE ADDRESS
      INB           ADDRESS OF NAME 
      STB FNAM      SAVE FOR CALL 
      ADB D2
      LDA B,I       GET WORD 4
      STA TEMP      SAVE
      AND MASK      EXTRACT TYPE/STATUS 
      IOR B40       PUT IN BLANK
      STA B,I 
      JSB IDRPD     DO RP,, THING 
       DEF *+2
FNAM   NOP          ID ADDRESS
      STA IERR      SAVE ERROR CODE 
      LDA TEMP      RETREIVE SAVED TYPE STATUS
      LDB TPNTR 
      ADB D3
      STA B,I       RESTORE WORD 4
      LDB TPNTR     AND B 
      LDA IERR      RETREIVE ERROR
      JMP FLUSH,I 
* 
*     DO ROUND ROBIN TO MAKE ID AVAILABLE 
*     JSB ROBIN 
* 
ROBIN NOP 
      LDB RROBN     GET ROUND ROBIN POINTER 
      STB QBLNK     SAVE TEMP 
      JMP RR1       SKIP FIRST TIME 
RLP1  LDB RROBN     GET ROUND ROBIN POINTER 
      CPB QBLNK     FULL CIRCLE ? 
      JMP ROBIN,I   YES - EXIT
RR1   CPB TBLAD     BEGINING OF TABLE ? 
      LDB TEND      YES - START AT BOTTOM 
      ADB DM5       ADJUST TO PREVIOUS ENTRY
      STB RROBN     SAVE
      ADB D3        TYPE STATUS WORD
      LDA B,I       GET TYPE/STATUS 
      CPA DM1       VALID ENTRY ? 
      JMP RLP1      NO - KEEP LOOKING 
      AND B17       EXTRACT TYPE
      CPA D3        IS IT TYPE 3 ?
      JMP RLP1      YES - LOOK AGAIN
      LDB RROBN 
      JSB FLUSH     DO RP,, 
      SZA           SUCCESS ? 
      JMP RLP1      THIS ID NOT AVAIL TRY NEXT
      ISZ ROBIN     BUMP RETURN (P+2) 
      JMP ROBIN,I   GOOD EXIT 
* 
      SKP 
* 
*  READ HEADER RECORD OF TYPE 6 FILE
*  FILE MUST BE OPEN AND DISC LU IN A REG.
* 
* 
SYSUP NOP           SYSTEM SETUP CODE WORD
LOOK  NOP 
      IOR PRC       MERGE IN PRIVILEDGE CODE
      STA TEMP      SAVE DISC LU FOR EXEC CALL
      JSB EXEC
       DEF *+7
       DEF D1        READ 
       DEF TEMP      DISC LU
DFIDB  DEF IDBUF     DEST BUFFER ADDRESS
       DEF D35       LENGTH 
       DEF DCB+3     DISC TRACK 
       DEF DCB+4     DISC SECTOR
      LDA $OPSY     CHECK IF RTE-IV SYSTEM
      LDB D28 
      CPA RT4FL     IF RTE-IV, USE MORE WORDS FOR CHECKSUB
      ADB D5        MAKE IT 33 FOR RTE-IV 
      STB LOOK1     SAVE FOR CHECKSUM 
      CLA,CLE       NOW CHECK FOR BELONGS THIS SYSTEM 
      JSB SUM 
       DEF IDBUF
LOOK1  DEC 28 
      LDB LOOK1     GET INDEX INTO SKELITON DCB 
      ADB DFIDB 
      CPA B,I       SAME ?
      INB,RSS       YES - SKIP
      JMP ERR19     CHECKSUM ERROR
      LDA SYSUP     GET THE SYSTEM SETUP CODE WORD
      CPA B,I       SAME AS THIS SYSTEM?
      RSS           YES - SKIP
      JMP ERR19     CHECKSUM ERROR
      LDA ID+15     GET TYPE WORD 
      AND B17       MASK TO TYPE
      CPA SEGT      SEGMENT ? 
      RSS           YES - SKIP
      JMP ERR19     NO - CLOSE FILE 
      LDA DCB       GET DISC LU 
      ERA           LSB 'LU' TO E REG.
      LDA DCB+3     GET TRACK 
      ALF,ALF       FOR DISC WORD 
      ERA           ADD LU IN BIT 15
      LDB DCB+4     GET SECTOR
      ADA B         PUT TOGETHER DISC WORD
      STA NAME+3    PUT IN OUR TABLE
      AND OM200     STRIP OUT SECTOR
      ADB D2        BUMP TO WHERE CODE STARTS 
      CPB DCB+8     CHECK FOR TRACK CROSSING
      LDB B200      BUMP TRACK AND ZERO SECTOR
      ADA B         FORM DISC WORD FOR ID 
      STA ID+27     PUT IN SKELETON ID
      ISZ LOOK      GOOD RETURN 
ERR19 JMP LOOK,I
      SPC 1 
DM9   DEC -9
RT4FL EQU DM9 
      SKP 
* 
*  FIND A BLANK SHORT ID AND SET IT UP
* 
FID   NOP 
      JSB $LIBR     GO PRIVILEDGE 
      NOP           TO PREVENT CONFLICTS
      JSB IDSGA     SEE IF ID NOW IN CORE 
       DEF *+2
DNAMF  DEF NAME 
      SEZ,CME       NOT FOUND CLEAR E REG.
      JMP SERCH 
      LDA D23       FOUND IN CORE 
      JMP FXIT      ERROR 23 !
LOOP1 LDA D14 
      SEZ,RSS       IF DOWN TO DONT CARE ?
      JMP FXIT      NO ID AVAILABLE 
*     E=1 SEARCH FOR ID W/O TRACKS, E=0 DONT CARE ABOUT TRACKS
SERCH CME           TOGGLR E REG. 
      LDA KEYWD     ADDRESS OF ID TABLE 
      STA TEMP
      RSS           SKIP FIRST ISZ
FIDL  ISZ TEMP
      LDB TEMP,I    GET ENTRY 
      SZB,RSS       END OF TABLE ?
      JMP LOOP1     TRY WITH TRACKS 
      ADB D14       BUMP TO WORD 15 
      LDA B,I       GET NAME/TYPE 
      AND OM360     MASK TO CHAR 5 AND SHORT BIT
      CPA B20       NULL AND SHORT ?
      RSS           YES - SKIP
      JMP FIDL      LOOK SOME MORE
      ADB D5        CHECK FOR TRACKS
      LDB B,I       WORD 20 
      SEZ,SZB       IF HAS TRACKS AND CARE
      JMP FIDL      SKIP THIS ONE 
*     NOW SET UP THE ID 
      LDB TEMP,I    GET AVAILABLE ID ADDRESS
      ADB D11       CORRECT FOR SHORT ID
      LDA ID+8      ENTRY POINT ADDRESS 
      STA B,I       TO THE ID 
      INB 
      LDA DNAMF     SEGMENT NAME
      JSB MOVE      MOVE FIRST
DM2    DEC -2       TWO WORDS 
      LDA NAME+2    GET THIRD WORD
      AND MASK      SAVE CHAR 5 
      XOR ID+15     MERGE IN PROG TYPE
      AND OM20      MASK OF BITS 4-14 
      XOR ID+15 
      IOR B220      PUT IN TEMP & SHORT BITS
      STA B,I       MOVE TO ID
      INB 
      LDA DID23     ADDRESS OF LOW MAIN ADDRESS 
      JSB MOVE      MOVE WORDS 23-27
DM5    DEC -5 
      CLA           GOOD EXIT 
FXIT  JSB $LIBX 
       DEF FID
* 
*     MOVE ROUTINE  A=SOURCE , B=DESTINATION ADDRESSES
* 
MOVE  NOP 
      STA ID+18     SAVE SOURCE ADDRESS 
      LDA MOVE,I    GET COUNTER 
      STA ID+19     SAVE
      ISZ MOVE      SET RETURN
MORE  LDA ID+18,I   GET NEXT WORD 
      STA B,I       PUT IT
      INB 
      ISZ ID+18 
      ISZ ID+19 
      JMP MORE
      JMP MOVE,I    RETURN - B=NEXT ADDRESS 
* 
*     SUM  ! P+1=ADDR. ,P+2=#  OF WORDS 
* 
SUM   NOP 
      LDB SUM,I 
      ISZ SUM 
      STB MOVE      TEMP
      LDB SUM,I     GET # OF WORDS
      CMB,INB       NEGATE
      ISZ SUM 
      ADA MOVE,I    ACCUMULATE SUM
      ISZ MOVE
      INB,SZB 
      JMP *-3 
      JMP SUM,I 
* 
      END T5IDM 
                                                                                