ASMB,R,L,C
      HED TYPE 5 ID MANAGER FOR RTE II/III
*     NAM T5IDM,3,40 PRE REL 10-14-76 (MOS) 
*     NAM T5IDM,3,40 09570-16539 REV. A 761013
*     NAM T5IDM,3,40 PRE RELEASE REV. B 770324
      NAM T5IDM,3,40 PRE-REL REV. D 780604 (DLB) RTE-IV 
* 
* 
*-------------------------------------------------------- 
* 
*     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.. 
      EXT RMPAR,LOPEN,LCLOS,FSTAT 
      EXT IDSGA,IDRPD,$LIBR,$LIBX 
*780604      EXT .OPSY  
* 
A     EQU 0 
B     EQU 1 
EQTA  EQU 1650B 
KEYWD EQU 1657B 
XEQT  EQU 1717B 
BPA1  EQU 1742B 
BPA3  EQU 1744B 
SECT2 EQU 1757B 
SECT3 EQU 1760B 
TATSD EQU 1756B 
      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 
      CCA           CALCULATE THE LAST TRACK NUMBER ON
      ADA TATSD     SYSTEM DISC 
      STA TEMP      SAVE FOR LATER
      JSB EXEC      GO READ THE :CL OF THE DISC 
      DEF *+7 
      DEF O1
      DEF PRC2      SYSTEM DISC 
      DEF SYSIA 
      DEF D128
      DEF TEMP
      DEF D0        SECTOR ZERO 
      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  EQU EFLAG 
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 
O1    EQU D1
D2    DEC 2 
O2    EQU D2
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
DM9   DEC -9
RT4FL EQU DM9 
* 
***************************************************** 
      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) 
**
**--------------------------------------------------------
**
**     RELOC.       09570-16499 
**     SOURCE       09570-18499 
**
**     M. SPANN           13 OCT 76 REV.
**
**--------------------------------------------------------- 
**
*      ENT IDGT#,IDMG#
*      EXT EXEC 
**
*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
*      LDB A,I       GET THE DISC ADDRESS WORD
*      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 
*      LDB B,I       GET THE VALUE IN THE TAT TABLE 
*      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   LDB DEFER     T5IDM NOT FOUND
*      DLD B,I       ERROR FLAG TO A
*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     GO GET THE SYSTEM ID WORD 
*  PREVIOUS WORD IS PATCHED OUT AFTER 1ST EXECUTION 
      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
      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 
      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
      JSB NAM..     CHECK IF NAME IS LEGAL ?
       DEF *+2
       DEF NAME 
      SZA 
      JMP MORE?     NOT LEGAL SO FORGET IT
      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 ? 
      RSS           YES DO ROUND ROBIN
      JMP MORE?     NO - IGNORE 
      JSB ROBIN     MAKE AN ID 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 
* 
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
                                                                                                                                                                                                                